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