X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FUtils.hs;h=7537eafcffacf7d8edf755e2bb8fea30cd636547;hb=c9a269666f2d60d9c5ba817e1c43b45f6d77de22;hp=c07c9c9cf94891bf82213f5c24edf293ef534f12;hpb=46ea3a688edea377e83794d1387f3f2d203bb0c6;p=Lucu.git diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index c07c9c9..7537eaf 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -1,52 +1,63 @@ {-# LANGUAGE - OverloadedStrings - , RecordWildCards - , TemplateHaskell + FlexibleContexts + , OverloadedStrings , UnicodeSyntax #-} -- |Utility functions used internally in this package. module Network.HTTP.Lucu.Utils - ( splitBy + ( Host + , PathSegment + , Path + + , splitBy , quoteStr , parseWWWFormURLEncoded - , splitPathInfo + , uriHost + , uriPathSegments , trim - , getLastModified + , (⊲) + , (⊳) + , (⋈) + , mapM - , liftByteString - , liftLazyByteString - , liftAscii - , liftCIAscii - , liftText - , liftMap - , liftUTCTime + , getLastModified ) where -import Control.Applicative -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.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.Ascii () +import Data.Convertible.Instances.Text () +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 Data.Time.Clock.POSIX -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.Directory -import System.Time (ClockTime(..)) + +-- |'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,22 +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 ∷ 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) - (ab ⊕ b2ab x ⊕ A.toAsciiBuilder "\\\"") + → go (BS.tail y) + (ab ⊕ b2ab x ⊕ cs ("\\\"" ∷ Ascii)) - b2ab ∷ Strict.ByteString → AsciiBuilder - b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString + b2ab ∷ ByteString → AsciiBuilder + b2ab = cs ∘ A.unsafeFromByteString -- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" -- [("aaa", "bbb"), ("ccc", "ddd")] @@ -87,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 @@ -96,20 +107,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 ∘ 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 Strict.pack reqPath + BS.pack <$> reqPath -- |>>> trim " ab c d " -- "ab c d" @@ -118,63 +136,34 @@ trim = reverse ∘ f ∘ reverse ∘ f where f = dropWhile isSpace --- |Get the modification time of a given file. -getLastModified ∷ FilePath → IO UTCTime -getLastModified = (clockTimeToUTC <$>) ∘ getModificationTime - where - clockTimeToUTC ∷ ClockTime → UTCTime - clockTimeToUTC (TOD sec picoSec) - = posixSecondsToUTCTime - $ fromRational - $ sec % 1 + picoSec % (1000 ⋅ 1000 ⋅ 1000 ⋅ 1000) - --- |Convert a 'ByteString' to an 'Exp' representing it as a literal. -liftByteString ∷ ByteString → Q Exp -liftByteString bs - = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |] - --- |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 $(liftByteString $ A.toByteString a) |] - --- |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] +infixr 5 ⊲ +-- | (⊲) = ('<|') +-- +-- U+22B2, NORMAL SUBGROUP OF +(⊲) ∷ Sequence α a ⇒ a → α → α +(⊲) = (<|) --- |Convert an 'UTCTime' to an 'Exp' representing it as a literal. -liftUTCTime ∷ UTCTime → Q Exp -liftUTCTime (UTCTime {..}) - = [| UTCTime $(liftDay utctDay) $(liftDiffTime utctDayTime) |] +infixl 5 ⊳ +-- | (⊳) = ('|>') +-- +-- U+22B3, CONTAINS AS NORMAL SUBGROUP +(⊳) ∷ Sequence α a ⇒ α → a → α +(⊳) = (|>) -liftDay ∷ Day → Q Exp -liftDay (ModifiedJulianDay {..}) - = [| ModifiedJulianDay $(lift toModifiedJulianDay) |] +infixr 5 ⋈ +-- | (⋈) = ('><') +-- +-- U+22C8, BOWTIE +(⋈) ∷ Sequence α a ⇒ α → α → α +(⋈) = (><) -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 +-- |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