X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FUtils.hs;h=297ea3a762ef64992466469a3845053ffb86d7af;hp=55acf0adc481929338a4639c7c88118f614a7e76;hb=6680828c79aff38431704075c339e043b577589e;hpb=4e41b11200285142757434e9d67e17ed20fae455 diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 55acf0a..297ea3a 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -1,48 +1,62 @@ {-# LANGUAGE - OverloadedStrings - , RecordWildCards - , 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 + , uriHost + , uriPathSegments , trim - , liftByteString - , liftLazyByteString - , liftAscii - , liftCIAscii - , liftText - , liftMap - , liftUTCTime + + , (⊲) + , (⊳) + , (⋈) + , mapM + + , getLastModified ) where -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 Strict -import qualified Data.ByteString.Unsafe as Strict -import qualified Data.ByteString.Lazy.Internal as Lazy +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.Time () +import Data.Maybe import Data.Monoid.Unicode -import Data.Ratio import Data.Text (Text) import qualified Data.Text as T import Data.Time -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Syntax import Network.URI -import Prelude hiding (last) +import Prelude hiding (last, mapM, null, reverse) import Prelude.Unicode -import System.IO.Unsafe +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"] @@ -63,17 +77,17 @@ quoteStr str = A.toAsciiBuilder "\"" ⊕ go (A.toByteString str) (∅) ⊕ A.toAsciiBuilder "\"" where - go ∷ Strict.ByteString → AsciiBuilder → AsciiBuilder + go ∷ ByteString → AsciiBuilder → AsciiBuilder go bs ab - = case Strict.break (≡ '"') bs of + = case BS.break (≡ '"') bs of (x, y) - | Strict.null y + | BS.null y → ab ⊕ b2ab x | otherwise - → go (Strict.tail y) + → go (BS.tail y) (ab ⊕ b2ab x ⊕ A.toAsciiBuilder "\\\"") - b2ab ∷ Strict.ByteString → AsciiBuilder + b2ab ∷ ByteString → AsciiBuilder b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString -- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" @@ -92,20 +106,27 @@ parseWWWFormURLEncoded src ) where unescape ∷ String → ByteString - unescape = Strict.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 ∘ T.pack ∘ 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 Strict.pack reqPath + BS.pack <$> reqPath -- |>>> trim " ab c d " -- "ab c d" @@ -114,70 +135,34 @@ trim = reverse ∘ f ∘ reverse ∘ f where f = dropWhile isSpace --- |Convert a 'ByteString' to an 'Exp' representing it as a literal. -liftByteString ∷ ByteString → Q Exp -liftByteString bs - = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |] +infixr 5 ⊲ +-- | (⊲) = ('<|') +-- +-- U+22B2, NORMAL SUBGROUP OF +(⊲) ∷ Sequence α a ⇒ a → α → α +(⊲) = (<|) --- |Convert a 'Lazy.ByteString' to an 'Exp' representing it as a --- literal. -liftLazyByteString ∷ Lazy.ByteString → Q Exp -liftLazyByteString = Lazy.foldrChunks f [| Lazy.Empty |] - where - f ∷ ByteString → Q Exp → Q Exp - f bs e = [| Lazy.Chunk $(liftByteString bs) $e |] - --- |Convert an 'Ascii' to an 'Exp' representing it as a literal. -liftAscii ∷ Ascii → Q Exp -liftAscii a = [| A.unsafeFromByteString - $ unsafePerformIO - $ Strict.unsafePackAddressLen $len $ptr - |] - where - bs ∷ Strict.ByteString - bs = A.toByteString a - - len, ptr ∷ Q Exp - len = lift $ Strict.length bs - ptr = litE $ stringPrimL $ Strict.unpack bs - --- |Convert a 'CIAscii' to an 'Exp' representing it as a literal. -liftCIAscii ∷ CIAscii → Q Exp -liftCIAscii a = [| A.toCIAscii $(liftAscii $ A.fromCIAscii a) |] - --- |Convert a 'Text' to an 'Exp' representing it as a literal. -liftText ∷ Text → Q Exp -liftText t = [| T.pack $(litE $ stringL $ T.unpack t) |] - --- |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.null m = [| M.empty |] - | otherwise = [| M.fromDistinctAscList $(liftPairs (M.toAscList m)) |] - where - liftPairs = listE ∘ map liftPair - liftPair (k, v) = tupE [liftK k, liftV v] - --- |Convert an 'UTCTime' to an 'Exp' representing it as a literal. -liftUTCTime ∷ UTCTime → Q Exp -liftUTCTime (UTCTime {..}) - = [| UTCTime { - utctDay = $(liftDay utctDay) - , utctDayTime = $(liftDiffTime utctDayTime) - } - |] - -liftDay ∷ Day → Q Exp -liftDay (ModifiedJulianDay {..}) - = [| ModifiedJulianDay { - toModifiedJulianDay = $(lift toModifiedJulianDay) - } - |] - -liftDiffTime ∷ DiffTime → Q Exp -liftDiffTime dt = [| fromRational ($n % $d) ∷ DiffTime |] - where - n, d ∷ Q Exp - n = lift $ numerator $ toRational dt - d = lift $ denominator $ toRational dt +infixl 5 ⊳ +-- | (⊳) = ('|>') +-- +-- U+22B3, CONTAINS AS NORMAL SUBGROUP +(⊳) ∷ Sequence α a ⇒ α → a → α +(⊳) = (|>) + +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