X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FUtils.hs;h=7537eafcffacf7d8edf755e2bb8fea30cd636547;hb=c9a269666f2d60d9c5ba817e1c43b45f6d77de22;hp=5cee03a56f6262c7d40ab1fe7059a566236cda73;hpb=5e561403ba8ad9c440cc2bf2bacb61ebc3c7a111;p=Lucu.git diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 5cee03a..7537eaf 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -1,41 +1,63 @@ {-# LANGUAGE - OverloadedStrings - , TemplateHaskell + FlexibleContexts + , OverloadedStrings , UnicodeSyntax #-} --- |Utility functions used internally in the Lucu httpd. These --- functions may be useful too for something else. +-- |Utility functions used internally in this package. module Network.HTTP.Lucu.Utils - ( splitBy + ( Host + , PathSegment + , Path + + , splitBy , quoteStr , parseWWWFormURLEncoded - , splitPathInfo - , show3 + , uriHost + , uriPathSegments , trim - , liftCIAscii - , liftText - , liftMap + + , (⊲) + , (⊳) + , (⋈) + , mapM + + , getLastModified ) where -import Blaze.ByteString.Builder.ByteString as B -import Blaze.Text.Int as BT -import Control.Monad -import Data.Ascii (Ascii, CIAscii, AsciiBuilder) +import Control.Applicative hiding (empty) +import Control.Monad hiding (mapM) +import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import Data.Char -import Data.List hiding (last) -import Data.Map (Map) -import qualified Data.Map as M +import Data.Collections +import Data.Collections.BaseInstances () +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Instances.Text () +import Data.Convertible.Instances.Time () +import Data.Maybe import Data.Monoid.Unicode import Data.Text (Text) -import qualified Data.Text as T -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax +import Data.Time import Network.URI -import Prelude hiding (last) +import Prelude hiding (last, mapM, null, reverse) import Prelude.Unicode +import System.Directory + +-- |'Host' represents an IP address or a host name in an URI +-- authority. +type Host = CI Text + +-- |'PathSegment' represents an URI path segment, split by slashes and +-- percent-decoded. +type PathSegment = ByteString + +-- |'Path' is a list of URI path segments. +type Path = [PathSegment] -- |>>> splitBy (== ':') "ab:c:def" -- ["ab", "c", "def"] @@ -52,20 +74,22 @@ splitBy isSep src -- >>> quoteStr "ab\"c" -- "\"ab\\\"c\"" quoteStr ∷ Ascii → AsciiBuilder -quoteStr str = A.toAsciiBuilder "\"" ⊕ - go (A.toByteString str) (∅) ⊕ - A.toAsciiBuilder "\"" +quoteStr str = cs ("\"" ∷ Ascii) ⊕ + go (cs str) (∅) ⊕ + cs ("\"" ∷ Ascii) where - go ∷ BS.ByteString → AsciiBuilder → AsciiBuilder + go ∷ ByteString → AsciiBuilder → AsciiBuilder go bs ab = case BS.break (≡ '"') bs of (x, y) - | BS.null y → ab ⊕ b2ab x - | otherwise → go (BS.tail y) (ab ⊕ b2ab x - ⊕ A.toAsciiBuilder "\\\"") + | BS.null y + → ab ⊕ b2ab x + | otherwise + → go (BS.tail y) + (ab ⊕ b2ab x ⊕ cs ("\\\"" ∷ Ascii)) - b2ab ∷ BS.ByteString → AsciiBuilder - b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString + b2ab ∷ ByteString → AsciiBuilder + b2ab = cs ∘ A.unsafeFromByteString -- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" -- [("aaa", "bbb"), ("ccc", "ddd")] @@ -74,7 +98,7 @@ parseWWWFormURLEncoded src -- THINKME: We could gain some performance by using attoparsec -- here. | src ≡ "" = [] - | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (A.toString src) + | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (cs src) let (key, value) = break (≡ '=') pairStr return ( unescape key , unescape $ case value of @@ -83,33 +107,27 @@ parseWWWFormURLEncoded src ) where unescape ∷ String → ByteString - unescape = BS.pack ∘ unEscapeString ∘ map plusToSpace + unescape = BS.pack ∘ unEscapeString ∘ (plusToSpace <$>) plusToSpace ∷ Char → Char plusToSpace '+' = ' ' plusToSpace c = c --- |>>> splitPathInfo "http://example.com/foo/bar" +-- |>>> uriHost "http://example.com/foo/bar" +-- "example.com" +uriHost ∷ URI → Host +{-# INLINE uriHost #-} +uriHost = CI.mk ∘ cs ∘ uriRegName ∘ fromJust ∘ uriAuthority + +-- |>>> uriPathSegments "http://example.com/foo/bar" -- ["foo", "bar"] -splitPathInfo ∷ URI → [ByteString] -splitPathInfo uri +uriPathSegments ∷ URI → Path +uriPathSegments uri = let reqPathStr = uriPath uri - reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)] + reqPath = [ unEscapeString x + | x ← splitBy (≡ '/') reqPathStr, (¬) (null x) ] in - map BS.pack reqPath - --- |>>> show3 5 --- "005" -show3 ∷ Integral n ⇒ n → AsciiBuilder -{-# INLINEABLE show3 #-} -show3 = A.unsafeFromBuilder ∘ go - where - go i | i ≥ 0 ∧ i < 10 = B.fromByteString "00" ⊕ BT.digit i - | i ≥ 0 ∧ i < 100 = B.fromByteString "0" ⊕ BT.integral i - | i ≥ 0 ∧ i < 1000 = BT.integral i - | otherwise = error ("show3: the integer i must satisfy 0 <= i < 1000: " ⧺ show i) --- FIXME: Drop this function as soon as possible, to eliminate the --- dependency on blaze-textual. + BS.pack <$> reqPath -- |>>> trim " ab c d " -- "ab c d" @@ -118,24 +136,34 @@ trim = reverse ∘ f ∘ reverse ∘ f where f = dropWhile isSpace --- |Convert a 'CIAscii' to an 'Exp' representing it as a literal. -liftCIAscii ∷ CIAscii → Q Exp -liftCIAscii a = [| A.toCIAscii (A.unsafeFromString $(strLit a)) |] - where - strLit ∷ CIAscii → Q Exp - strLit = liftString ∘ A.toString ∘ A.fromCIAscii +infixr 5 ⊲ +-- | (⊲) = ('<|') +-- +-- U+22B2, NORMAL SUBGROUP OF +(⊲) ∷ Sequence α a ⇒ a → α → α +(⊲) = (<|) --- |Convert a 'Text' to an 'Exp' representing it as a literal. -liftText ∷ Text → Q Exp -liftText t = [| T.pack $(strLit t) |] - where - strLit ∷ Text → Q Exp - strLit = liftString ∘ T.unpack +infixl 5 ⊳ +-- | (⊳) = ('|>') +-- +-- U+22B3, CONTAINS AS NORMAL SUBGROUP +(⊳) ∷ Sequence α a ⇒ α → a → α +(⊳) = (|>) --- |Convert an arbitrary 'Map' to an 'Exp' representing it as a --- literal, using a given key lifter and a value lifter. -liftMap ∷ Eq k ⇒ (k → Q Exp) → (v → Q Exp) → Map k v → Q Exp -liftMap liftK liftV m = [| M.fromAscList $(liftPairs $ M.toAscList m) |] - where - liftPairs = listE ∘ map liftPair - liftPair (k, v) = tupE [liftK k, liftV v] +infixr 5 ⋈ +-- | (⋈) = ('><') +-- +-- U+22C8, BOWTIE +(⋈) ∷ Sequence α a ⇒ α → α → α +(⋈) = (><) + +-- |Generalised @mapM@ from any 'Foldable' to 'Unfoldable'. Why isn't +-- this in the @collections-api@? +mapM ∷ (Foldable α a, Unfoldable β b, Functor m, Monad m) + ⇒ (a → m b) → α → m β +{-# INLINE mapM #-} +mapM = flip foldrM empty ∘ (flip ((<$>) ∘ flip insert) ∘) + +-- |Get the modification time of a given file. +getLastModified ∷ FilePath → IO UTCTime +getLastModified = (cs <$>) ∘ getModificationTime