]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Utils.hs
Destroy Data.Eq.Indirect
[Lucu.git] / Network / HTTP / Lucu / Utils.hs
1 {-# LANGUAGE
2     FlexibleContexts
3   , OverloadedStrings
4   , UnicodeSyntax
5   #-}
6 -- |Utility functions used internally in this package.
7 module Network.HTTP.Lucu.Utils
8     ( Host
9     , PathSegment
10     , Path
11
12     , splitBy
13     , quoteStr
14     , parseWWWFormURLEncoded
15     , uriHost
16     , uriPathSegments
17     , trim
18
19     , (⊲)
20     , (⊳)
21     , (⋈)
22     , mapM
23
24     , getLastModified
25     )
26     where
27 import Control.Applicative hiding (empty)
28 import Control.Monad hiding (mapM)
29 import Data.Ascii (Ascii, AsciiBuilder)
30 import qualified Data.Ascii as A
31 import Data.ByteString (ByteString)
32 import qualified Data.ByteString.Char8 as BS
33 import Data.CaseInsensitive (CI)
34 import qualified Data.CaseInsensitive as CI
35 import Data.Char
36 import Data.Collections
37 import Data.Collections.BaseInstances ()
38 import Data.Convertible.Base
39 import Data.Convertible.Instances.Ascii ()
40 import Data.Convertible.Instances.Text ()
41 import Data.Convertible.Instances.Time ()
42 import Data.Maybe
43 import Data.Monoid.Unicode
44 import Data.Text (Text)
45 import Data.Time
46 import Network.URI
47 import Prelude hiding (last, mapM, null, reverse)
48 import Prelude.Unicode
49 import System.Directory
50
51 -- |'Host' represents an IP address or a host name in an URI
52 -- authority.
53 type Host = CI Text
54
55 -- |'PathSegment' represents an URI path segment, split by slashes and
56 -- percent-decoded.
57 type PathSegment = ByteString
58
59 -- |'Path' is a list of URI path segments.
60 type Path = [PathSegment]
61
62 -- |>>> splitBy (== ':') "ab:c:def"
63 -- ["ab", "c", "def"]
64 splitBy ∷ (a → Bool) → [a] → [[a]]
65 {-# INLINEABLE splitBy #-}
66 splitBy isSep src
67     = case break isSep src of
68         (last , []       ) → [last]
69         (first, _sep:rest) → first : splitBy isSep rest
70
71 -- |>>> quoteStr "abc"
72 -- "\"abc\""
73 --
74 -- >>> quoteStr "ab\"c"
75 -- "\"ab\\\"c\""
76 quoteStr ∷ Ascii → AsciiBuilder
77 quoteStr str = cs ("\"" ∷ Ascii) ⊕
78                go (cs str) (∅)   ⊕
79                cs ("\"" ∷ Ascii)
80     where
81       go ∷ ByteString → AsciiBuilder → AsciiBuilder
82       go bs ab
83           = case BS.break (≡ '"') bs of
84               (x, y)
85                   | BS.null y
86                       → ab ⊕ b2ab x
87                   | otherwise
88                       → go (BS.tail y)
89                            (ab ⊕ b2ab x ⊕ cs ("\\\"" ∷ Ascii))
90
91       b2ab ∷ ByteString → AsciiBuilder
92       b2ab = cs ∘ A.unsafeFromByteString
93
94 -- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
95 -- [("aaa", "bbb"), ("ccc", "ddd")]
96 parseWWWFormURLEncoded ∷ Ascii → [(ByteString, ByteString)]
97 parseWWWFormURLEncoded src
98     -- THINKME: We could gain some performance by using attoparsec
99     -- here.
100     | src ≡ ""  = []
101     | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (cs src)
102                      let (key, value) = break (≡ '=') pairStr
103                      return ( unescape key
104                             , unescape $ case value of
105                                            ('=':val) → val
106                                            val       → val
107                             )
108     where
109       unescape ∷ String → ByteString
110       unescape = BS.pack ∘ unEscapeString ∘ (plusToSpace <$>)
111
112       plusToSpace ∷ Char → Char
113       plusToSpace '+' = ' '
114       plusToSpace c   = c
115
116 -- |>>> uriHost "http://example.com/foo/bar"
117 -- "example.com"
118 uriHost ∷ URI → Host
119 {-# INLINE uriHost #-}
120 uriHost = CI.mk ∘ cs ∘ uriRegName ∘ fromJust ∘ uriAuthority
121
122 -- |>>> uriPathSegments "http://example.com/foo/bar"
123 -- ["foo", "bar"]
124 uriPathSegments ∷ URI → Path
125 uriPathSegments uri
126     = let reqPathStr = uriPath uri
127           reqPath    = [ unEscapeString x
128                          | x ← splitBy (≡ '/') reqPathStr, (¬) (null x) ]
129       in
130         BS.pack <$> reqPath
131
132 -- |>>> trim "  ab c d "
133 -- "ab c d"
134 trim ∷ String → String
135 trim = reverse ∘ f ∘ reverse ∘ f
136     where
137       f = dropWhile isSpace
138
139 infixr 5 ⊲
140 -- | (&#x22B2;) = ('<|')
141 --
142 -- U+22B2, NORMAL SUBGROUP OF
143 (⊲) ∷ Sequence α a ⇒ a → α → α
144 (⊲) = (<|)
145
146 infixl 5 ⊳
147 -- | (&#x22B3;) = ('|>')
148 --
149 -- U+22B3, CONTAINS AS NORMAL SUBGROUP
150 (⊳) ∷ Sequence α a ⇒ α → a → α
151 (⊳) = (|>)
152
153 infixr 5 ⋈
154 -- | (&#x22C8;) = ('><')
155 --
156 -- U+22C8, BOWTIE
157 (⋈) ∷ Sequence α a ⇒ α → α → α
158 (⋈) = (><)
159
160 -- |Generalised @mapM@ from any 'Foldable' to 'Unfoldable'. Why isn't
161 -- this in the @collections-api@?
162 mapM ∷ (Foldable α a, Unfoldable β b, Functor m, Monad m)
163      ⇒ (a → m b) → α → m β
164 {-# INLINE mapM #-}
165 mapM = flip foldrM empty ∘ (flip ((<$>) ∘ flip insert) ∘)
166
167 -- |Get the modification time of a given file.
168 getLastModified ∷ FilePath → IO UTCTime
169 getLastModified = (cs <$>) ∘ getModificationTime