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