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