blob: a5ba378624068288a28885c12119084d86f8ea1e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}
module Data.Torrent.InfoHash
( InfoHash (getInfoHash)
, addHashToURI
-- * Construction
, hash, hashlazy
-- * Extra
, ppHex
) where
import Control.Applicative
import Data.BEncode
import Data.Char
import Data.List as L
import Data.Foldable
import Data.Map (Map)
import qualified Data.Map as M
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Builder.Prim as B
import qualified Data.ByteString.Lazy as Lazy
import Data.Serialize
import qualified Crypto.Hash.SHA1 as C
import Network.URI
import Numeric
-- | Exactly 20 bytes long SHA1 hash.
newtype InfoHash = InfoHash { getInfoHash :: ByteString }
deriving (Eq, Ord, BEncodable)
instance Show InfoHash where
show = BC.unpack . ppHex
instance Serialize InfoHash where
put = putByteString . getInfoHash
get = InfoHash <$> getBytes 20
instance BEncodable a => BEncodable (Map InfoHash a) where
{-# SPECIALIZE instance BEncodable a => BEncodable (Map InfoHash a) #-}
fromBEncode b = M.mapKeys InfoHash <$> fromBEncode b
{-# INLINE fromBEncode #-}
toBEncode = toBEncode . M.mapKeys getInfoHash
{-# INLINE toBEncode #-}
hash :: ByteString -> InfoHash
hash = InfoHash . C.hash
hashlazy :: Lazy.ByteString -> InfoHash
hashlazy = InfoHash . C.hashlazy
ppHex :: InfoHash -> ByteString
ppHex = Lazy.toStrict . B.toLazyByteString .
foldMap (B.primFixed B.word8HexFixed) . B.unpack . getInfoHash
addHashToURI :: URI -> InfoHash -> URI
addHashToURI uri s = uri {
uriQuery = uriQuery uri ++ mkPref (uriQuery uri) ++
"info_hash=" ++ rfc1738Encode (BC.unpack (getInfoHash s))
}
where
mkPref [] = "?"
mkPref ('?' : _) = "&"
mkPref _ = error "addHashToURI"
rfc1738Encode = L.concatMap (\c -> if unreservedS c then [c] else encodeHex c)
where
unreservedS = (`L.elem` chars)
chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_./"
encodeHex c = '%' : pHex c
pHex c = let p = (showHex . ord $ c) ""
in if L.length p == 1 then '0' : p else p
|
