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