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.Maybe
  39 import Data.Monoid.Unicode
  40 import Data.Ratio
  41 import Data.Text (Text)
  42 import qualified Data.Text as T
  43 import Data.Time
  44 import Data.Time.Clock.POSIX
  45 import Network.URI
  46 import Prelude hiding (last, mapM, null, reverse)
  47 import Prelude.Unicode
  48 import System.Directory
  49 import System.Time (ClockTime(..))
  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 = A.toAsciiBuilder "\"" ⊕
  78                go (A.toByteString str) (∅) ⊕
  79                A.toAsciiBuilder "\""
  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 ⊕ A.toAsciiBuilder "\\\"")
  90
  91       b2ab ∷ ByteString → AsciiBuilder
  92       b2ab = A.toAsciiBuilder ∘ 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 ≡ '&') (A.toString 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 ∘ T.pack ∘ 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 = (clockTimeToUTC <$>) ∘ getModificationTime
 170     where
 171       clockTimeToUTC ∷ ClockTime → UTCTime
 172       clockTimeToUTC (TOD sec picoSec)
 173           = posixSecondsToUTCTime ∘ fromRational
 174             $ sec % 1 + picoSec % (1000 ⋅ 1000 ⋅ 1000 ⋅ 1000)