module Main (main) where
import Control.Applicative
import Control.Monad
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii)
+import Data.Attempt
import Data.Char
+import Data.Convertible.Base
+import Data.Convertible.Utils
import Data.Maybe
import Language.Haskell.TH.PprLib
import Language.Haskell.TH.Syntax
= case mimeTypeOpts of
[] → Nothing
OptMIMEType ty:[]
- → case A.fromChars ty of
- Just a → Just $ parseMIMEType a
- Nothing → error "MIME types must not contain any non-ASCII letters."
+ → case convertAttemptVia ((⊥) ∷ Ascii) ty of
+ Success a → Just a
+ Failure e → error (show e)
_ → error "too many --mime-type options."
where
mimeTypeOpts ∷ [CmdOpt]
strToETag ∷ String → ETag
strToETag str
- = case A.fromChars str of
- Just a → strongETag a
- Nothing → error "ETag must not contain any non-ASCII letters."
+ = case ca str of
+ Success a → strongETag a
+ Failure e → error (show e)
openOutput ∷ [CmdOpt] → IO Handle
openOutput opts
Library
Build-Depends:
ascii == 0.0.*,
- attoparsec == 0.9.*,
+ attempt == 0.3.*,
+ attoparsec == 0.10.*,
base == 4.*,
base-unicode-symbols == 0.2.*,
base64-bytestring == 0.1.*,
collections-api == 1.0.*,
collections-base-instances == 1.0.*,
containers == 0.4.*,
+ convertible-ascii == 0.1.*,
+ convertible-text == 0.4.*,
+ data-default == 0.3.*,
directory == 1.1.*,
filepath == 1.2.*,
mtl == 2.0.*,
stm == 2.2.*,
stringsearch == 0.3.*,
syb == 0.3.*,
+ tagged == 0.2.*,
template-haskell == 2.5.*,
text == 0.11.*,
time == 1.2.*,
- time-http == 0.2.*,
+ time-http == 0.4.*,
transformers == 0.2.*
if flag(ssl)
, ETag(..)
, strongETag
, weakETag
- , parseETag
-- *** MIME Type
, MIMEType(..)
, MIMEParams
- , parseMIMEType
, mimeType
-- *** Authentication
{-# LANGUAGE
- OverloadedStrings
+ FlexibleInstances
+ , MultiParamTypeClasses
+ , OverloadedStrings
+ , TemplateHaskell
, UnicodeSyntax
#-}
-- |An internal module for HTTP authentication.
, Realm
, UserID
, Password
-
- , printAuthChallenge
, authCredential
)
where
import Control.Monad
-import Data.Ascii (Ascii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, AsciiBuilder)
+import Data.Attempt
import Data.Attoparsec.Char8
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as C8
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
-- |'Password' is just an 'Ascii' string.
type Password = Ascii
--- |Convert an 'AuthChallenge' to 'Ascii'.
-printAuthChallenge ∷ AuthChallenge → Ascii
-printAuthChallenge (BasicAuthChallenge realm)
- = A.fromAsciiBuilder $
- A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm
+instance ConvertSuccess AuthChallenge Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess AuthChallenge AsciiBuilder where
+ {-# INLINE convertSuccess #-}
+ convertSuccess (BasicAuthChallenge realm)
+ = cs ("Basic realm=" ∷ Ascii) ⊕ quoteStr realm
+
+deriveAttempts [ ([t| AuthChallenge |], [t| Ascii |])
+ , ([t| AuthChallenge |], [t| AsciiBuilder |])
+ ]
-- |'Parser' for an 'AuthCredential'.
authCredential ∷ Parser AuthCredential
base64 = inClass "a-zA-Z0-9+/="
asc ∷ C8.ByteString → Parser Ascii
- asc bs = case A.fromByteString bs of
- Just as → return as
- Nothing → fail "Non-ascii character in auth credential"
+ asc bs = case ca bs of
+ Success as → return as
+ Failure _ → fail "Non-ascii character in auth credential"
#if defined(HAVE_SSL)
, SSLConfig(..)
#endif
- , defaultConfig
)
where
import Data.Ascii (Ascii)
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
+import Data.Default
import Data.Text (Text)
-import qualified Data.Text as T
import Network
import Network.BSD
import Network.HTTP.Lucu.MIMEType.Guess
-- |The default configuration. Generally you can use this value as-is,
-- or possibly you just want to replace the 'cnfServerSoftware' and
-- 'cnfServerPort'. SSL connections are disabled by default.
-defaultConfig ∷ Config
-defaultConfig = Config {
- cnfServerSoftware = "Lucu/1.0"
- , cnfServerHost = CI.mk ∘ T.pack $ unsafePerformIO getHostName
- , cnfServerPort = "http"
- , cnfServerV4Addr = Just "0.0.0.0"
- , cnfServerV6Addr = Just "::"
+instance Default Config where
+ def = Config {
+ cnfServerSoftware = "Lucu/1.0"
+ , cnfServerHost = CI.mk ∘ cs $ unsafePerformIO getHostName
+ , cnfServerPort = "http"
+ , cnfServerV4Addr = Just "0.0.0.0"
+ , cnfServerV6Addr = Just "::"
#if defined(HAVE_SSL)
- , cnfSSLConfig = Nothing
+ , cnfSSLConfig = Nothing
#endif
- , cnfMaxPipelineDepth = 100
- , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
- , cnfDumpTooLateAbortionToStderr = True
- , cnfExtToMIMEType = defaultExtensionMap
- }
--- FIXME: use data-default.
+ , cnfMaxPipelineDepth = 100
+ , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB
+ , cnfDumpTooLateAbortionToStderr = True
+ , cnfExtToMIMEType = defaultExtensionMap
+ }
{-# LANGUAGE
OverloadedStrings
, RecordWildCards
+ , ScopedTypeVariables
, TypeOperators
, UnicodeSyntax
#-}
where
import Blaze.ByteString.Builder (Builder)
import Data.Ascii (Ascii)
-import qualified Data.Ascii as A
import qualified Data.CaseInsensitive as CI
+import Data.Convertible.Base
+import Data.Convertible.Utils
import Data.Maybe
import Data.Monoid.Unicode
import Data.Text (Text)
defaultPageForResponse conf req res
= defaultPageWithMessage conf (resStatus res) $ defaultMessage req res
-defaultPageWithMessage ∷ StatusCode sc ⇒ Config → sc → Html → Builder
+defaultPageWithMessage ∷ ∀sc. StatusCode sc ⇒ Config → sc → Html → Builder
{-# INLINEABLE defaultPageWithMessage #-}
defaultPageWithMessage (Config {..}) sc msg
= renderHtmlBuilder $
do unsafeByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
docType
html ! xmlns "http://www.w3.org/1999/xhtml" $
- do let status = toHtml ∘ A.toText ∘ A.fromAsciiBuilder $ printStatusCode sc
+ do let status = toHtml $ scText sc
head $ title status
body $ do h1 status
p msg
hr
- address $ do toHtml $ A.toText cnfServerSoftware
+ address $ do toHtml (cs cnfServerSoftware ∷ Text)
unsafeByteString " at "
toHtml $ CI.original cnfServerHost
+ where
+ scText ∷ sc → Text
+ scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode
defaultMessage ∷ Maybe Request → Response → Html
{-# INLINEABLE defaultMessage #-}
path = toHtml ∘ uriPath ∘ reqURI $ fromJust req
loc ∷ Text
- loc = A.toText ∘ fromJust $ getHeader "Location" res
+ loc = cs ∘ fromJust $ getHeader "Location" res
hr ∷ Html
{-# INLINE hr #-}
{-# LANGUAGE
DeriveDataTypeable
+ , FlexibleInstances
+ , MultiParamTypeClasses
, OverloadedStrings
, RecordWildCards
, TemplateHaskell
-- |An internal module for entity tags.
module Network.HTTP.Lucu.ETag
( ETag(..)
- , parseETag
- , printETag
-
, strongETag
, weakETag
, eTag
import Control.Applicative
import Control.Monad
import Data.Ascii (Ascii, AsciiBuilder)
-import qualified Data.Ascii as A
import Data.Attoparsec.Char8
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
import Data.Data
import Data.Monoid.Unicode
import Language.Haskell.TH.Syntax
import Network.HTTP.Lucu.OrphanInstances ()
-import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http hiding (token)
import Network.HTTP.Lucu.Utils
import Prelude.Unicode
}
|]
--- |Convert an 'ETag' to an 'AsciiBuilder'.
-printETag ∷ ETag → AsciiBuilder
-{-# INLINEABLE printETag #-}
-printETag et
- = ( if etagIsWeak et then
- A.toAsciiBuilder "W/"
- else
- (∅)
- )
- ⊕
- quoteStr (etagToken et)
+instance ConvertSuccess ETag Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess ETag AsciiBuilder where
+ {-# INLINE convertSuccess #-}
+ convertSuccess (ETag {..})
+ = ( if etagIsWeak then
+ cs ("W/" ∷ Ascii)
+ else
+ (∅)
+ )
+ ⊕
+ quoteStr etagToken
--- |Parse 'Etag' from an 'Ascii'. This functions throws an exception
--- for parse error.
-parseETag ∷ Ascii → ETag
-{-# INLINEABLE parseETag #-}
-parseETag str
- = case parseOnly (finishOff eTag) $ A.toByteString str of
- Right et → et
- Left err → error ("unparsable ETag: " ⧺ A.toString str ⧺ ": " ⧺ err)
+deriveAttempts [ ([t| ETag |], [t| Ascii |])
+ , ([t| ETag |], [t| AsciiBuilder |])
+ ]
-- |This is equivalent to @'ETag' 'False'@. If you want to generate an
-- ETag from a file, try using
module Network.HTTP.Lucu.Headers
( Headers
, HasHeaders(..)
-
, headers
- , printHeaders
)
where
import Control.Applicative hiding (empty)
import Control.Monad
import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
+import Data.Attoparsec.Char8
import qualified Data.Collections.Newtype.TH as C
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
import Data.List (intersperse)
import qualified Data.Map as M (Map)
import Data.Collections
getCIHeader ∷ CIAscii → a → Maybe CIAscii
{-# INLINE getCIHeader #-}
- getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader
+ getCIHeader = ((cs <$>) ∘) ∘ getHeader
deleteHeader ∷ CIAscii → a → a
{-# INLINE deleteHeader #-}
{-# INLINE nullA #-}
nullA = null ∘ A.toByteString
+instance ConvertSuccess Headers Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess Headers AsciiBuilder where
+ {-# INLINEABLE convertSuccess #-}
+ convertSuccess (Headers m)
+ = mconcat (header <$> fromFoldable m) ⊕ cs ("\x0D\x0A" ∷ Ascii)
+ where
+ header ∷ (CIAscii, Ascii) → AsciiBuilder
+ {-# INLINE header #-}
+ header (name, value)
+ = cs name ⊕
+ cs (": " ∷ Ascii) ⊕
+ cs value ⊕
+ cs ("\x0D\x0A" ∷ Ascii)
+
+deriveAttempts [ ([t| Headers |], [t| Ascii |])
+ , ([t| Headers |], [t| AsciiBuilder |])
+ ]
+
{-
message-header = field-name ":" [ field-value ]
field-name = token
-}
headers ∷ Parser Headers
{-# INLINEABLE headers #-}
-headers = do xs ← P.many header
+headers = do xs ← many header
crlf
return $ fromFoldable xs
where
header ∷ Parser (CIAscii, Ascii)
- header = do name ← A.toCIAscii <$> token
+ header = do name ← cs <$> token
void $ char ':'
skipMany lws
values ← content `sepBy` try lws
joinValues ∷ [Ascii] → Ascii
{-# INLINE joinValues #-}
- joinValues = A.fromAsciiBuilder
+ joinValues = cs
∘ mconcat
- ∘ intersperse (A.toAsciiBuilder "\x20")
- ∘ (A.toAsciiBuilder <$>)
-
-printHeaders ∷ Headers → AsciiBuilder
-printHeaders (Headers m)
- = mconcat (printHeader <$> fromFoldable m) ⊕
- A.toAsciiBuilder "\x0D\x0A"
- where
- printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
- printHeader (name, value)
- = A.toAsciiBuilder (A.fromCIAscii name) ⊕
- A.toAsciiBuilder ": " ⊕
- A.toAsciiBuilder value ⊕
- A.toAsciiBuilder "\x0D\x0A"
+ ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder)
+ ∘ (cs <$>)
{-# LANGUAGE
- OverloadedStrings
+ FlexibleInstances
+ , MultiParamTypeClasses
+ , OverloadedStrings
+ , TemplateHaskell
, UnicodeSyntax
#-}
-- |An internal module for HTTP version numbers.
module Network.HTTP.Lucu.HttpVersion
( HttpVersion(..)
- , printHttpVersion
, httpVersion
)
where
import Control.Applicative
import Control.Applicative.Unicode
-import Data.Ascii (AsciiBuilder)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, AsciiBuilder)
import Data.Attoparsec.Char8
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
import Data.Monoid.Unicode
import Prelude hiding (min)
+import Prelude.Unicode
-- |An HTTP version consists of major and minor versions.
data HttpVersion
| minA < minB = LT
| otherwise = EQ
--- |Convert an 'HttpVersion' to 'AsciiBuilder'.
-printHttpVersion ∷ HttpVersion → AsciiBuilder
-printHttpVersion v
- = case v of
- -- Optimisation for special cases.
- HttpVersion 1 0 → A.toAsciiBuilder "HTTP/1.0"
- HttpVersion 1 1 → A.toAsciiBuilder "HTTP/1.1"
- -- General (but almost never stumbling) cases.
- HttpVersion maj min
- → A.toAsciiBuilder "HTTP/" ⊕
- A.toAsciiBuilder (A.unsafeFromString $ show maj) ⊕
- A.toAsciiBuilder "." ⊕
- A.toAsciiBuilder (A.unsafeFromString $ show min)
+instance ConvertSuccess HttpVersion Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess HttpVersion AsciiBuilder where
+ {-# INLINE convertSuccess #-}
+ convertSuccess v
+ = case v of
+ -- Optimisation for special cases.
+ HttpVersion 1 0 → cs ("HTTP/1.0" ∷ Ascii)
+ HttpVersion 1 1 → cs ("HTTP/1.1" ∷ Ascii)
+ -- General (but almost never occuring) cases.
+ HttpVersion maj min
+ → cs ("HTTP/" ∷ Ascii) ⊕
+ convertUnsafe (show maj) ⊕
+ cs ("." ∷ Ascii) ⊕
+ convertUnsafe (show min)
+
+deriveAttempts [ ([t| HttpVersion |], [t| Ascii |])
+ , ([t| HttpVersion |], [t| AsciiBuilder |])
+ ]
-- |'Parser' for an 'HttpVersion'.
httpVersion ∷ Parser HttpVersion
where
import Codec.Compression.GZip
import Control.Applicative
-import qualified Data.Ascii as A
import qualified Data.ByteString.Lazy as L
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
import Data.Digest.Pure.SHA
import Data.Maybe
import Data.Time
mkETagFromInput ∷ L.ByteString → ETag
mkETagFromInput input
- = strongETag $ A.unsafeFromString
+ = strongETag $ convertUnsafe
$ "SHA-1:" ⧺ showDigest (sha1 input)
{-# LANGUAGE
DoAndIfThenElse
+ , FlexibleContexts
+ , MultiParamTypeClasses
, OverloadedStrings
, RecordWildCards
, TemplateHaskell
where
import Codec.Compression.GZip
import Control.Monad
-import Data.Ascii (CIAscii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, CIAscii)
import qualified Data.ByteString.Lazy as L
import Data.Char
import Data.Collections
+import Data.Convertible.Base
+import Data.Convertible.Utils
import Data.List (intersperse)
import Data.Monoid
import Data.Ratio
]
else
text " Compression: disabled"
- , text " MIME Type:" <+> mimeTypeToDoc iType
- , text " ETag:" <+> eTagToDoc iETag
+ , text " MIME Type:" <+> toDoc iType
+ , text " ETag:" <+> toDoc iETag
, text " Last Modified:" <+> text (show iLastMod)
]
, text " -}"
, text "{-# LANGUAGE MagicHash #-}"
]
where
- eTagToDoc ∷ ETag → Doc
- eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag
-
- mimeTypeToDoc ∷ MIMEType → Doc
- mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
+ toDoc ∷ ConvertSuccess α Ascii ⇒ α → Doc
+ toDoc = text ∘ convertSuccessVia ((⊥) ∷ Ascii)
moduleDecl ∷ ModName → Name → Doc
moduleDecl modName symName
import Control.Concurrent.STM
import Data.Ascii (Ascii)
import Data.ByteString (ByteString)
+import Data.Convertible.Base
import Data.Monoid.Unicode
+import Data.Proxy
import Data.Sequence (Seq)
import Data.Time
-import qualified Data.Time.HTTP as HTTP
+import Data.Time.Format.HTTP
import Data.Typeable
import Network.Socket
import Network.HTTP.Lucu.Config
#if defined(HAVE_SSL)
import OpenSSL.X509
#endif
+import Prelude.Unicode
class Typeable i ⇒ Interaction i where
toInteraction ∷ i → SomeInteraction
type InteractionQueue = TVar (Seq SomeInteraction)
mkInteractionQueue ∷ IO InteractionQueue
+{-# INLINE mkInteractionQueue #-}
mkInteractionQueue = newTVarIO (∅)
getCurrentDate ∷ IO Ascii
-getCurrentDate = HTTP.toAscii <$> getCurrentTime
+{-# INLINE getCurrentDate #-}
+getCurrentDate = flip proxy http ∘ cs <$> getCurrentTime
-- (<http://tools.ietf.org/html/rfc2231>).
module Network.HTTP.Lucu.MIMEParams
( MIMEParams
- , printMIMEParams
, mimeParams
)
where
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
+import Data.Attoparsec.Char8
import Data.Bits
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Collections
import Data.Collections.BaseInstances ()
import qualified Data.Collections.Newtype.TH as C
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
import qualified Data.Map as M (Map)
import Data.Monoid.Unicode
import Data.Sequence (Seq)
instance SortingCollection MIMEParams (CIAscii, Text)
|]
--- |Convert MIME parameter values to an 'AsciiBuilder'.
-printMIMEParams ∷ MIMEParams → AsciiBuilder
-{-# INLINEABLE printMIMEParams #-}
-printMIMEParams = foldl' f (∅)
- where
- f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder
- {-# INLINE f #-}
- f ab (k, v) = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v
+instance ConvertSuccess MIMEParams Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess MIMEParams AsciiBuilder where
+ {-# INLINEABLE convertSuccess #-}
+ convertSuccess = foldl' f (∅)
+ where
+ f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder
+ {-# INLINE f #-}
+ f ab (k, v) = ab ⊕ cs ("; " ∷ Ascii) ⊕ printPair k v
printPair ∷ CIAscii → Text → AsciiBuilder
{-# INLINEABLE printPair #-}
printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder
{-# INLINEABLE printPairInUTF8 #-}
printPairInUTF8 name value
- = A.toAsciiBuilder (A.fromCIAscii name) ⊕
- A.toAsciiBuilder "*=utf-8''" ⊕
+ = cs name ⊕
+ cs ("*=utf-8''" ∷ Ascii) ⊕
escapeUnsafeChars (encodeUtf8 value) (∅)
printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder
{-# INLINEABLE printPairInAscii #-}
printPairInAscii name value
- = A.toAsciiBuilder (A.fromCIAscii name) ⊕
- A.toAsciiBuilder "=" ⊕
- if BS.any ((¬) ∘ isToken) (A.toByteString value) then
+ = cs name ⊕
+ cs ("=" ∷ Ascii) ⊕
+ if BS.any ((¬) ∘ isToken) (cs value) then
quoteStr value
else
- A.toAsciiBuilder value
+ cs value
escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
{-# INLINEABLE escapeUnsafeChars #-}
Nothing → b
Just (c, bs')
| isToken c → escapeUnsafeChars bs' $
- b ⊕ A.toAsciiBuilder (A.unsafeFromString [c])
+ b ⊕ cs (A.unsafeFromString [c])
| otherwise → escapeUnsafeChars bs' $
b ⊕ toHex (fromIntegral $ fromEnum c)
toHex ∷ Word8 → AsciiBuilder
{-# INLINEABLE toHex #-}
-toHex o = A.toAsciiBuilder "%" ⊕
- A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8)
- , toHex' (o .&. 0x0F) ])
+toHex o = cs ("%" ∷ Ascii) ⊕
+ cs (A.unsafeFromString [ toHex' (o `shiftR` 8)
+ , toHex' (o .&. 0x0F) ])
where
toHex' ∷ Word8 → Char
{-# INLINEABLE toHex' #-}
| otherwise = toEnum $ fromIntegral
$ fromEnum 'A' + fromIntegral (h - 0x0A)
+deriveAttempts [ ([t| MIMEParams |], [t| Ascii |])
+ , ([t| MIMEParams |], [t| AsciiBuilder |])
+ ]
+
data ExtendedParam
= InitialEncodedParam {
epName ∷ !CIAscii
-- |'Parser' for MIME parameter values.
mimeParams ∷ Parser MIMEParams
{-# INLINEABLE mimeParams #-}
-mimeParams = decodeParams =≪ P.many (try paramP)
+mimeParams = decodeParams =≪ many (try paramP)
paramP ∷ Parser ExtendedParam
paramP = do skipMany lws
return $ AsciiParam name sect payload
nameP ∷ Parser (CIAscii, Integer, Bool)
-nameP = do name ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
+nameP = do name ← (cs ∘ A.unsafeFromByteString) <$>
takeWhile1 (\c → isToken c ∧ c ≢ '*')
sect ← option 0 $ try (char '*' *> decimal )
isEncoded ← option False $ try (char '*' *> pure True)
return (charset, payload)
where
metadata ∷ Parser CIAscii
- metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
+ metadata = (cs ∘ A.unsafeFromByteString) <$>
takeWhile (\c → c ≢ '\'' ∧ isToken c)
encodedPayload ∷ Parser BS.ByteString
{-# INLINE encodedPayload #-}
-encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars)
+encodedPayload = BS.concat <$> many (hexChar <|> rawChars)
hexChar ∷ Parser BS.ByteString
{-# INLINEABLE hexChar #-}
→ fail (concat [ "Duplicate section "
, show $ section x
, " for parameter '"
- , A.toString $ A.fromCIAscii $ epName x
+ , cs $ epName x
, "'"
])
→ fail (concat [ "Missing section "
, show $ section p
, " for parameter '"
- , A.toString $ A.fromCIAscii $ epName p
+ , cs $ epName p
, "'"
])
Just (ContinuedEncodedParam {..}, _)
→ fail "decodeSeq: internal error: CEP at section 0"
Just (AsciiParam {..}, xs)
- → let t = A.toText apPayload
- in
- decodeSeq' Nothing xs $ singleton t
+ → decodeSeq' Nothing xs $ singleton $ cs apPayload
decodeSeq' ∷ Monad m
⇒ Maybe Decoder
→ fail (concat [ "Section "
, show epSection
, " for parameter '"
- , A.toString $ A.fromCIAscii epName
+ , cs epName
, "' is encoded but its first section is not"
])
Just (AsciiParam {..}, xs)
- → let t = A.toText apPayload
- in
- decodeSeq' decoder xs $ chunks ⊳ t
+ → decodeSeq' decoder xs $ chunks ⊳ cs apPayload
type Decoder = BS.ByteString → Either UnicodeException Text
getDecoder charset
| charset ≡ "UTF-8" = return decodeUtf8'
| charset ≡ "US-ASCII" = return decodeUtf8'
- | otherwise = fail $ "No decoders found for charset: "
- ⧺ A.toString (A.fromCIAscii charset)
+ | otherwise = fail $ "No decoders found for charset: " ⊕ cs charset
{-# LANGUAGE
DeriveDataTypeable
+ , FlexibleInstances
+ , MultiParamTypeClasses
, OverloadedStrings
, RecordWildCards
, TemplateHaskell
-- (<http://tools.ietf.org/html/rfc2046>).
module Network.HTTP.Lucu.MIMEType
( MIMEType(..)
-
- , parseMIMEType
- , printMIMEType
-
, mimeType
, mimeTypeList
)
where
import Control.Applicative
import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
-import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
+import Data.Attoparsec.Char8
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
import Data.Monoid.Unicode
import Data.Typeable
import Language.Haskell.TH.Syntax
}
|]
--- |Convert a 'MIMEType' to an 'AsciiBuilder'.
-printMIMEType ∷ MIMEType → AsciiBuilder
-{-# INLINEABLE printMIMEType #-}
-printMIMEType (MIMEType {..})
- = A.toAsciiBuilder (A.fromCIAscii mtMedia) ⊕
- A.toAsciiBuilder "/" ⊕
- A.toAsciiBuilder (A.fromCIAscii mtSub) ⊕
- printMIMEParams mtParams
+instance ConvertSuccess MIMEType Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess MIMEType AsciiBuilder where
+ {-# INLINEABLE convertSuccess #-}
+ convertSuccess (MIMEType {..})
+ = cs mtMedia ⊕
+ cs ("/" ∷ Ascii) ⊕
+ cs mtSub ⊕
+ cs mtParams
+
+deriveAttempts [ ([t| MIMEType |], [t| Ascii |])
+ , ([t| MIMEType |], [t| AsciiBuilder |])
+ ]
--- |Parse 'MIMEType' from an 'Ascii'. This function throws an
--- exception for parse error. For literals consider using
--- 'Network.HTTP.Lucu.MIMEType.TH.mimeType'.
-parseMIMEType ∷ Ascii → MIMEType
-{-# INLINEABLE parseMIMEType #-}
-parseMIMEType str
- = case parseOnly (finishOff mimeType) $ A.toByteString str of
- Right t → t
- Left err → error ("Unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err)
+-- |Parse 'MIMEType' from an 'Ascii'. For MIME type literals, consider
+-- using 'Network.HTTP.Lucu.MIMEType.TH.mimeType'.
+instance ConvertAttempt Ascii MIMEType where
+ {-# INLINEABLE convertAttempt #-}
+ convertAttempt str
+ = case parseOnly (finishOff mimeType) (cs str) of
+ Right t → return t
+ Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err)
-- |'Parser' for an 'MIMEType'.
mimeType ∷ Parser MIMEType
{-# INLINEABLE mimeType #-}
-mimeType = do media ← A.toCIAscii <$> token
+mimeType = do media ← cs <$> token
_ ← char '/'
- sub ← A.toCIAscii <$> token
+ sub ← cs <$> token
params ← mimeParams
return $ MIMEType media sub params
)
where
import Control.Applicative
-import Data.Attoparsec.Char8 as P
-import Data.Attoparsec.Lazy as LP
+import Data.Attoparsec.Char8
+import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString.Lazy.Char8 as Lazy
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
import qualified Data.Map as M
import Data.Map (Map)
import Data.Typeable
import Data.Monoid
import Data.Monoid.Unicode
import Data.Text (Text)
-import qualified Data.Text as T
import Data.Text.Encoding
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
"pair"
ext ∷ Parser Text
- ext = (decodeUtf8 <$> P.takeWhile1 isAlphaNum)
+ ext = (decodeUtf8 <$> takeWhile1 isAlphaNum)
<?>
"ext"
guessTypeByFileName (ExtMap m) fpath
= case takeExtension fpath of
[] → Nothing
- (_:ext) → M.lookup (T.pack ext) m
+ (_:ext) → M.lookup (cs ext) m
where
import Control.Monad.Unicode
import Data.Ascii (Ascii)
-import qualified Data.Ascii as A
+import Data.Attempt
+import Data.Convertible.Base
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Network.HTTP.Lucu.MIMEType hiding (mimeType)
-- @
mimeType ∷ QuasiQuoter
mimeType = QuasiQuoter {
- quoteExp = (lift ∘ parseMIMEType =≪) ∘ toAscii
+ quoteExp = (lift =≪) ∘ (parse =≪) ∘ toAscii
, quotePat = const unsupported
, quoteType = const unsupported
, quoteDec = const unsupported
}
where
+ parse ∷ Monad m ⇒ Ascii → m MIMEType
+ parse a
+ = case ca a of
+ Success t → return t
+ Failure e → fail (show e)
+
toAscii ∷ Monad m ⇒ String → m Ascii
- toAscii (A.fromChars ∘ trim → Just a) = return a
- toAscii str = fail $ "Malformed MIME Type: " ⧺ str
+ toAscii (trim → s)
+ = case ca s of
+ Success a → return a
+ Failure e → fail (show e)
unsupported ∷ Monad m ⇒ m α
unsupported = fail "Unsupported usage of mimeType quasi-quoter."
{-# LANGUAGE
DoAndIfThenElse
+ , FlexibleInstances
, FlexibleContexts
+ , MultiParamTypeClasses
, OverloadedStrings
, QuasiQuotes
, RecordWildCards
, ScopedTypeVariables
+ , TemplateHaskell
, UnicodeSyntax
, ViewPatterns
#-}
import Control.Applicative.Unicode hiding ((∅))
import Control.Monad.Error (MonadError, throwError)
import Control.Monad.Unicode
-import Data.Ascii (Ascii, CIAscii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
+import Data.Attempt
import Data.Attoparsec
import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LS
import Data.ByteString.Lazy.Search
import Data.Collections
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
import Data.List (intercalate)
import Data.Maybe
import Data.Monoid.Unicode
import Data.Sequence (Seq)
import Data.Text (Text)
-import qualified Data.Text as T
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.MIMEParams
import Network.HTTP.Lucu.MIMEType (MIMEType)
, dParams ∷ !MIMEParams
}
-printContDispo ∷ ContDispo → Ascii
-printContDispo d
- = A.fromAsciiBuilder
- ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
- ⊕
- printMIMEParams (dParams d) )
+instance ConvertSuccess ContDispo Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess ContDispo AsciiBuilder where
+ {-# INLINE convertSuccess #-}
+ convertSuccess (ContDispo {..})
+ = cs dType ⊕ cs dParams
+
+deriveAttempts [ ([t| ContDispo |], [t| Ascii |])
+ , ([t| ContDispo |], [t| AsciiBuilder |])
+ ]
-- |Parse \"multipart/form-data\" and return either @'Left' err@ or
-- @'Right' result@. Note that there are currently the following
prologue boundary
= ( (string "--" <?> "prefix")
*>
- (string (A.toByteString boundary) <?> "boundary")
+ (string (cs boundary) <?> "boundary")
*>
pure ()
)
Nothing
→ throwError "Content-Disposition is missing"
Just str
- → case parseOnly (finishOff contentDisposition) $ A.toByteString str of
+ → case parseOnly (finishOff contentDisposition) $ cs str of
Right d → return d
Left err → throwError $ "malformed Content-Disposition: "
- ⧺ A.toString str
- ⧺ ": "
- ⧺ err
+ â\8a\95 cs str
+ â\8a\95 ": "
+ â\8a\95 err
contentDisposition ∷ Parser ContDispo
contentDisposition
- = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
+ = (ContDispo <$> (cs <$> token) ⊛ mimeParams)
<?>
"contentDisposition"
Nothing
→ return Nothing
Just str
- → case parseOnly (finishOff MT.mimeType) $ A.toByteString str of
+ → case parseOnly (finishOff MT.mimeType) $ cs str of
Right d → return $ Just d
Left err → throwError $ "malformed Content-Type: "
- ⧺ A.toString str
- ⧺ ": "
- ⧺ err
+ â\8a\95 cs str
+ â\8a\95 ": "
+ â\8a\95 err
getBody ∷ MonadError String m
⇒ Ascii
→ LS.ByteString
→ m (LS.ByteString, LS.ByteString)
{-# INLINEABLE getBody #-}
-getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
+getBody (("\r\n--" ⊕) ∘ cs → boundary) src
= case breakOn boundary src of
(before, after)
| LS.null after
return (name, fd)
| otherwise
= throwError $ "disposition type is not \"form-data\": "
- ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
+ â\8a\95 cs (dType ptContDispo)
partName ∷ MonadError String m ⇒ Part → m Ascii
{-# INLINEABLE partName #-}
partName (Part {..})
= case lookup "name" $ dParams ptContDispo of
Just name
- → case A.fromText name of
- Just a → return a
- Nothing → throwError $ "Non-ascii part name: "
- ⧺ T.unpack name
+ → case ca name of
+ Success a → return a
+ Failure e → throwError $ show e
Nothing
→ throwError $ "form-data without name: "
- ⧺ A.toString (printContDispo ptContDispo)
+ â\8a\95 convertSuccessVia ((â\8a¥) â\88· Ascii) ptContDispo
partFileName ∷ Part → Maybe Text
partFileName (ptContDispo → ContDispo {..})
import Control.Monad
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P hiding (scan)
-import qualified Data.Attoparsec.FastSet as FS
+import Data.Attoparsec.Char8
import qualified Data.ByteString.Char8 as BS
import Network.HTTP.Lucu.Parser
import Prelude.Unicode
-- separators.
isSeparator ∷ Char → Bool
{-# INLINE isSeparator #-}
-isSeparator = flip FS.memberChar set
- where
- {-# NOINLINE set #-}
- set = FS.charClass "()<>@,;:\\\"/[]?={}\x20\x09"
+isSeparator = inClass "()<>@,;:\\\"/[]?={}\x20\x09"
-- |@'isChar' c@ returns 'True' iff @c <= 0x7f@.
isChar ∷ Char → Bool
quotedStr ∷ Parser Ascii
{-# INLINEABLE quotedStr #-}
quotedStr = do void $ char '"'
- xs ← P.many (qdtext <|> quotedPair)
+ xs ← many (qdtext <|> quotedPair)
void $ char '"'
return ∘ A.unsafeFromByteString $ BS.pack xs
<?>
import Control.Monad
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
-import qualified Data.Ascii as A
+import Data.Convertible.Base
import Data.Maybe
import Data.Monoid.Unicode
import GHC.Conc (unsafeIOToSTM)
, isError
])
$ abort'
- $ A.toAsciiBuilder "Inappropriate status code for a response: "
- ⊕ printStatusCode resStatus
+ $ cs ("Inappropriate status code for a response: " ∷ Ascii)
+ ⊕ cs resStatus
when ( resStatus ≈ MethodNotAllowed ∧
hasHeader "Allow" res )
$ abort'
- $ A.toAsciiBuilder "The status was "
- ⊕ printStatusCode resStatus
- ⊕ A.toAsciiBuilder " but no \"Allow\" header."
+ $ cs ("The status was " ∷ Ascii)
+ ⊕ cs resStatus
+ ⊕ cs (" but no \"Allow\" header." ∷ Ascii)
when ( resStatus ≉ NotModified ∧
isRedirection resStatus ∧
hasHeader "Location" res )
$ abort'
- $ A.toAsciiBuilder "The status code was "
- ⊕ printStatusCode resStatus
- ⊕ A.toAsciiBuilder " but no Location header."
+ $ cs ("The status code was " ∷ Ascii)
+ ⊕ cs resStatus
+ ⊕ cs (" but no Location header." ∷ Ascii)
abort' ∷ AsciiBuilder → STM ()
abort' = throwSTM
∘ mkAbortion' InternalServerError
- ∘ A.toText
- ∘ A.fromAsciiBuilder
+ ∘ cs
postprocessWithRequest ∷ NormalInteraction → STM ()
postprocessWithRequest ni@(NI {..})
import qualified Data.ByteString.Char8 as C8
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
import Data.Maybe
import Data.Text (Text)
-import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
parseHost ∷ Ascii → (CI Text, Ascii)
parseHost hp
- = let (h, p) = C8.break (≡ ':') $ A.toByteString hp
+ = let (h, p) = C8.break (≡ ':') $ cs hp
-- FIXME: should decode punycode here.
hText = CI.mk $ T.decodeUtf8 h
pAscii = A.unsafeFromByteString p
uri' = uri {
uriAuthority = Just URIAuth {
uriUserInfo = ""
- , uriRegName = T.unpack $ CI.original host
- , uriPort = A.toString port
+ , uriRegName = cs $ CI.original host
+ , uriPort = cs port
}
}
in
| otherwise
→ setStatus NotImplemented
- case A.toByteString <$> getHeader "Content-Length" req of
+ case cs <$> getHeader "Content-Length" req of
Nothing → return ()
Just value → case C8.readInt value of
Just (len, garbage)
import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
import Data.List
import Data.Maybe
import Data.Monoid.Unicode
import qualified Data.Sequence as S
-import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Chunk
= let abo = mkAbortion BadRequest [("Connection", "close")]
$ Just
$ "chunkWasMalformed: "
- ⊕ T.pack msg
+ ⊕ cs msg
⊕ ": "
- ⊕ T.pack (intercalate ", " eCtx)
+ ⊕ cs (intercalate ", " eCtx)
⊕ ": "
- ⊕ T.pack e
+ ⊕ cs e
in
throwTo tid abo
{-# LANGUAGE
CPP
, BangPatterns
+ , FlexibleContexts
, GeneralizedNewtypeDeriving
, DoAndIfThenElse
, OverloadedStrings
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Unicode
-import Data.Ascii (Ascii, CIAscii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
+import Data.Attempt
import qualified Data.Attoparsec.Char8 as P
import Data.ByteString (ByteString)
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.Collections
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
+import Data.Convertible.Utils
import Data.List (intersperse, sort)
import Data.Maybe
import Data.Monoid
import Data.Monoid.Unicode
+import Data.Proxy
+import Data.Tagged
import Data.Text (Text)
-import qualified Data.Text as T
import Data.Time
-import qualified Data.Time.HTTP as HTTP
+import Data.Time.Format.HTTP
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Authentication
import Network.HTTP.Lucu.Config
where
parse' = map toPairWithFormData ∘
parseWWWFormURLEncoded ∘
- fromJust ∘
- A.fromChars ∘
+ convertUnsafe ∘
drop 1 ∘
uriQuery
Nothing
→ return []
Just accept
- → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
+ → case P.parseOnly (finishOff MT.mimeTypeList) (cs accept) of
Right xs → return xs
Left _ → abort $ mkAbortion' BadRequest
- $ "Unparsable Accept: " ⊕ A.toText accept
+ $ "Unparsable Accept: " ⊕ cs accept
-- |Return the list of @(contentCoding, qvalue)@ enumerated on the
-- value of request header \"Accept-Encoding\". The list is sorted in
-- identity のみが許される。
return [("identity", Nothing)]
else
- case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
+ case P.parseOnly (finishOff acceptEncodingList) (cs ae) of
Right xs → return $ map toTuple $ reverse $ sort xs
Left _ → abort $ mkAbortion' BadRequest
- $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
+ $ "Unparsable Accept-Encoding: " ⊕ cs ae
where
toTuple (AcceptEncoding {..})
= (aeEncoding, aeQValue)
Nothing
→ return Nothing
Just cType
- → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
+ → case P.parseOnly (finishOff MT.mimeType) (cs cType) of
Right t → return $ Just t
Left _ → abort $ mkAbortion' BadRequest
- $ "Unparsable Content-Type: " ⊕ A.toText cType
+ $ "Unparsable Content-Type: " ⊕ cs cType
-- |Return the value of request header \"Authorization\" as
-- 'AuthCredential'.
Nothing
→ return Nothing
Just auth
- → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
+ → case P.parseOnly (finishOff authCredential) (cs auth) of
Right ac → return $ Just ac
Left _ → return Nothing
method ← getMethod
when (method ≡ GET ∨ method ≡ HEAD)
- $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
+ $ setHeader "Last-Modified"
+ $ flip proxy http
+ $ cs timeStamp
when (method ≡ POST)
$ abort
$ mkAbortion' InternalServerError
method ← getMethod
when (method ≡ GET ∨ method ≡ HEAD)
$ setHeader "ETag"
- $ A.fromAsciiBuilder
- $ printETag tag
+ $ cs tag
when (method ≡ POST)
$ abort
$ mkAbortion' InternalServerError
→ if value ≡ "*" then
return ()
else
- case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+ case P.parseOnly (finishOff eTagList) (cs value) of
Right tags
-- tags の中に一致するものが無ければ
-- PreconditionFailed で終了。
→ when ((¬) (any (≡ tag) tags))
$ abort
$ mkAbortion' PreconditionFailed
- $ "The entity tag doesn't match: " ⊕ A.toText value
+ $ "The entity tag doesn't match: " ⊕ cs value
Left _
→ abort $ mkAbortion' BadRequest
- $ "Unparsable If-Match: " ⊕ A.toText value
+ $ "Unparsable If-Match: " ⊕ cs value
let statusForNoneMatch
= if method ≡ GET ∨ method ≡ HEAD then
abort $ mkAbortion' statusForNoneMatch
$ "The entity tag matches: *"
else
- case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+ case P.parseOnly (finishOff eTagList) (cs value) of
Right tags
→ when (any (≡ tag) tags)
$ abort
$ mkAbortion' statusForNoneMatch
- $ "The entity tag matches: " ⊕ A.toText value
+ $ "The entity tag matches: " ⊕ cs value
Left _
→ abort $ mkAbortion' BadRequest
- $ "Unparsable If-None-Match: " ⊕ A.toText value
+ $ "Unparsable If-None-Match: " ⊕ cs value
driftTo ReceivingBody
method ← getMethod
when (method ≡ GET ∨ method ≡ HEAD)
- $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
+ $ setHeader "Last-Modified"
+ $ flip proxy http
+ $ cs timeStamp
when (method ≡ POST)
$ abort
$ mkAbortion' InternalServerError
ifModSince ← getHeader "If-Modified-Since"
case ifModSince of
- Just str → case HTTP.fromAscii str of
- Right lastTime
+ Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+ Just lastTime
→ when (timeStamp ≤ lastTime)
$ abort
$ mkAbortion' statusForIfModSince
- $ "The entity has not been modified since " ⊕ A.toText str
- Left e
+ $ "The entity has not been modified since " ⊕ cs str
+ Nothing
→ abort $ mkAbortion' BadRequest
- $ "Malformed If-Modified-Since: " ⊕ T.pack e
+ $ "Malformed If-Modified-Since: " ⊕ cs str
Nothing → return ()
ifUnmodSince ← getHeader "If-Unmodified-Since"
case ifUnmodSince of
- Just str → case HTTP.fromAscii str of
- Right lastTime
+ Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+ Just lastTime
→ when (timeStamp > lastTime)
$ abort
$ mkAbortion' PreconditionFailed
- $ "The entity has not been modified since " ⊕ A.toText str
- Left e
+ $ "The entity has not been modified since " ⊕ cs str
+ Nothing
→ abort $ mkAbortion' BadRequest
- $ "Malformed If-Unmodified-Since: " ⊕ T.pack e
+ $ "Malformed If-Unmodified-Since: " ⊕ cs str
Nothing → return ()
driftTo ReceivingBody
else
abort $ mkAbortion' RequestEntityTooLarge
$ "Request body must be smaller than "
- ⊕ T.pack (show limit)
+ ⊕ cs (show limit)
⊕ " bytes."
go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
if Strict.null c then
→ readMultipartFormData params
Just cType
→ abort $ mkAbortion' UnsupportedMediaType
- $ A.toText
- $ A.fromAsciiBuilder
- $ A.toAsciiBuilder "Unsupported media type: "
- ⊕ MT.printMIMEType cType
+ $ cs
+ $ ("Unsupported media type: " ∷ Ascii)
+ ⊕ cs cType
where
readWWWFormURLEncoded
= (map toPairWithFormData ∘ parseWWWFormURLEncoded)
(bsToAscii =≪ getChunks limit)
bsToAscii bs
- = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
- Just a → return a
- Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
+ = case convertAttemptVia ((⊥) ∷ ByteString) bs of
+ Success a → return a
+ Failure e → abort $ mkAbortion' BadRequest $ cs (show e)
readMultipartFormData m
= case lookup "boundary" m of
→ abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
Just boundary
→ do src ← getChunks limit
- b ← case A.fromText boundary of
- Just b → return b
- Nothing → abort $ mkAbortion' BadRequest
- $ "Malformed boundary: " ⊕ boundary
+ b ← case ca boundary of
+ Success b → return b
+ Failure _ → abort $ mkAbortion' BadRequest
+ $ "Malformed boundary: " ⊕ boundary
case parseMultipartFormData b src of
- Right xs → return $ map (first A.toByteString) xs
- Left err → abort $ mkAbortion' BadRequest $ T.pack err
+ Right xs → return $ map (first cs) xs
+ Left err → abort $ mkAbortion' BadRequest $ cs err
-- |@'redirect' code uri@ declares the response status as @code@ and
-- \"Location\" header field as @uri@. The @code@ must satisfy
= do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
$ abort
$ mkAbortion' InternalServerError
- $ A.toText
- $ A.fromAsciiBuilder
- $ A.toAsciiBuilder "Attempted to redirect with status "
- ⊕ printStatusCode sc
+ $ cs
+ $ ("Attempted to redirect with status " ∷ Ascii)
+ ⊕ cs (fromStatusCode sc)
setStatus sc
setLocation uri
-- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
-- mandatory for sending a response body.
setContentType ∷ MIMEType → Rsrc ()
-setContentType
- = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
+setContentType = setHeader "Content-Type" ∘ cs
-- |@'setLocation' uri@ declares the response header \"Location\" as
-- @uri@. You usually don't need to call this function directly.
setLocation ∷ URI → Rsrc ()
setLocation uri
- = case A.fromChars uriStr of
- Just a → setHeader "Location" a
- Nothing → abort $ mkAbortion' InternalServerError
- $ "Malformed URI: " ⊕ T.pack uriStr
+ = case ca uriStr of
+ Success a → setHeader "Location" a
+ Failure e → abort $ mkAbortion' InternalServerError
+ $ cs (show e)
where
uriStr = uriToString id uri ""
_ → abort $ mkAbortion' InternalServerError
"setContentEncoding: Unknown HTTP version"
setHeader "Content-Encoding"
- $ A.fromAsciiBuilder
+ $ cs
$ mconcat
- $ intersperse (A.toAsciiBuilder ", ")
+ $ intersperse (cs (", " ∷ Ascii))
$ map tr codings
where
- toAB = A.toAsciiBuilder ∘ A.fromCIAscii
+ toAB ∷ ConvertSuccess α AsciiBuilder ⇒ α → AsciiBuilder
+ toAB = cs
-- |@'setWWWAuthenticate' challenge@ declares the response header
-- \"WWW-Authenticate\" as @challenge@.
setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
-setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
+setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs
-- |Write a chunk in 'Strict.ByteString' to the response body. You
-- must first declare the response header \"Content-Type\" before
import Control.Monad.IO.Class
import Control.Monad.Reader (ReaderT, runReaderT, ask)
import Control.Monad.Unicode
-import Data.Ascii (Ascii, CIAscii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Collections
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
import Data.List (intersperse, nub)
import Data.Maybe
import Data.Monoid
import Data.Monoid.Unicode
-import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Abortion.Internal
import Network.HTTP.Lucu.Config
notAllowed ∷ Rsrc ()
notAllowed = do setStatus MethodNotAllowed
setHeader "Allow"
- $ A.fromAsciiBuilder
+ $ cs
$ mconcat
- $ intersperse (A.toAsciiBuilder ", ")
- $ map A.toAsciiBuilder allowedMethods
+ $ intersperse (cs (", " ∷ Ascii) ∷ AsciiBuilder)
+ $ map cs allowedMethods
allowedMethods ∷ [Ascii]
allowedMethods = nub $ concat [ methods resGet ["GET"]
toAbortion e
= case fromException e of
Just abortion → abortion
- Nothing → mkAbortion' InternalServerError $ T.pack $ show e
+ Nothing → mkAbortion' InternalServerError $ cs $ show e
processException ∷ SomeException → IO ()
processException exc
{-# LANGUAGE
- OverloadedStrings
+ FlexibleInstances
+ , MultiParamTypeClasses
+ , OverloadedStrings
, RecordWildCards
+ , TemplateHaskell
, UnicodeSyntax
, ViewPatterns
#-}
, emptyResponse
, setStatusCode
, resCanHaveBody
- , printStatusCode
- , printResponse
, (≈)
, (≉)
, isServerError
)
where
-import Data.Ascii (AsciiBuilder)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, AsciiBuilder)
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.StatusCode.Internal
import Prelude.Unicode
--- |Convert a 'StatusCode' to an 'AsciiBuilder'.
-printStatusCode ∷ StatusCode sc ⇒ sc → AsciiBuilder
-{-# INLINEABLE printStatusCode #-}
-printStatusCode = A.toAsciiBuilder ∘ textualStatus
-
-- |This is the definition of an HTTP response.
data Response = Response {
resVersion ∷ !HttpVersion
getHeaders = resHeaders
setHeaders res hdr = res { resHeaders = hdr }
+instance ConvertSuccess Response Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess Response AsciiBuilder where
+ {-# INLINE convertSuccess #-}
+ convertSuccess (Response {..})
+ = cs resVersion ⊕
+ cs (" " ∷ Ascii) ⊕
+ cs resStatus ⊕
+ cs ("\x0D\x0A" ∷ Ascii) ⊕
+ cs resHeaders
+
+deriveAttempts [ ([t| Response |], [t| Ascii |])
+ , ([t| Response |], [t| AsciiBuilder |])
+ ]
+
-- |Returns an HTTP\/1.1 'Response' with no header fields.
emptyResponse ∷ StatusCode sc ⇒ sc → Response
emptyResponse sc
| resStatus ≈ NotModified = False
| otherwise = True
--- |Convert a 'Response' to 'AsciiBuilder'.
-printResponse ∷ Response → AsciiBuilder
-{-# INLINEABLE printResponse #-}
-printResponse (Response {..})
- = printHttpVersion resVersion ⊕
- A.toAsciiBuilder " " ⊕
- printStatusCode resStatus ⊕
- A.toAsciiBuilder "\x0D\x0A" ⊕
- printHeaders resHeaders
-
-- |@'isInformational' sc@ returns 'True' iff @sc '<' 200@.
isInformational ∷ StatusCode sc ⇒ sc → Bool
{-# INLINE isInformational #-}
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
+import Data.Ascii (AsciiBuilder)
+import Data.Convertible.Utils
import GHC.IO.Exception (IOException(..), IOErrorType(..))
-import qualified Data.Ascii as A
import Data.Monoid.Unicode
import qualified Data.Sequence as S
import Data.Sequence (ViewR(..))
, resStatus = fromStatusCode Continue
, resHeaders = (∅)
}
- hPutBuilder cHandle $ A.toBuilder $ printResponse cont
+ hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont
hFlush cHandle
writeHeader ctx ni
readTVar niResponse
else
retry -- Too early to write header fields.
- hPutBuilder cHandle $ A.toBuilder $ printResponse res
+ hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) res
hFlush cHandle
writeBodyIfNeeded ctx ni
→ SemanticallyInvalidInteraction
→ IO ()
writeResponseForSEI ctx@(Context {..}) (SEI {..})
- = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
+ = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse
unless seiWillDiscardBody $
if seiWillChunkBody then
do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
→ SyntacticallyInvalidInteraction
→ IO ()
writeResponseForSYI (Context {..}) (SYI {..})
- = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
+ = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse
hPutBuilder cHandle syiBodyToSend
hFlush cHandle
return ()
import Control.Monad.Trans
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LBS
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
import Data.Monoid.Unicode
import Data.String
import qualified Data.Text as T
handleStaticFile sendContent path
where
dec8 ∷ ByteString → String
- dec8 = T.unpack ∘ T.decodeUtf8
+ dec8 = cs ∘ T.decodeUtf8
securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
securityCheck pathElems
{-# LANGUAGE
- QuasiQuotes
+ OverloadedStrings
+ , QuasiQuotes
#-}
-- |Definition of HTTP status code.
-- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named status
{-# LANGUAGE
ExistentialQuantification
, FlexibleInstances
+ , MultiParamTypeClasses
+ , OverlappingInstances
, TemplateHaskell
, UnicodeSyntax
, ViewPatterns
#-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Network.HTTP.Lucu.StatusCode.Internal
( StatusCode(..)
, SomeStatusCode(..)
)
where
import Control.Applicative
-import Data.Ascii (Ascii)
+import Data.Ascii (Ascii, AsciiBuilder)
import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
-import Data.Attoparsec.Lazy as LP
+import Data.Attoparsec.Char8
+import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString.Lazy.Char8 as Lazy
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
import Data.List
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
numericCode ∷ sc → Int
-- |Return the combination of 3-digit integer and reason phrase
-- for this status e.g. @200 OK@
- textualStatus ∷ sc → Ascii
+ textualStatus ∷ sc → AsciiBuilder
-- |Wrap the status code into 'SomeStatusCode'.
fromStatusCode ∷ sc → SomeStatusCode
fromStatusCode = SomeStatusCode
textualStatus (SomeStatusCode sc) = textualStatus sc
fromStatusCode = id
+instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = textualStatus
+
+instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
+ {-# INLINE convertAttempt #-}
+ convertAttempt = return ∘ cs
+
+instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
+ {-# INLINE convertAttempt #-}
+ convertAttempt = return ∘ cs
+
-- |'QuasiQuoter' for 'StatusCode' declarations.
--
-- Top-level splicing
-- data OK = OK deriving ('Show')
-- instance OK where
-- 'numericCode' _ = 200
--- 'textualStatus' _ = 'A.unsafeFromString' \"200 OK\"
+-- 'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
--
-- data BadRequest = BadRequest deriving ('Show')
-- instance BadRequest where
-- 'numericCode' _ = 400
--- 'textualStatus' _ = 'A.unsafeFromString' \"400 Bad Request\"
+-- 'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
--
-- data MethodNotAllowed = MethodNotAllowed deriving ('Show')
-- instance MethodNotAllowed where
-- 'numericCode' _ = 405
--- 'textualStatus' _ = 'A.unsafeFromString' \"405 Method Not Allowed\"
+-- 'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
-- @
statusCodes ∷ QuasiQuoter
statusCodes = QuasiQuoter {
"pair"
word ∷ Parser Ascii
- word = A.unsafeFromByteString <$> P.takeWhile1 isAlpha_ascii
+ word = A.unsafeFromByteString <$> takeWhile1 isAlpha_ascii
statusDecl ∷ (Int, [Ascii]) → Q [Dec]
statusDecl (num, phrase)
return (a:bs)
where
name ∷ Name
- name = mkName $ concatMap A.toString phrase
+ name = mkName $ concatMap cs phrase
dataDecl ∷ Q Dec
dataDecl = dataD (cxt []) name [] [con] [''Show]
con = return $ NormalC name []
txt ∷ Q Exp
- txt = [| A.unsafeFromString $(lift txt') |]
+ txt = [| cs ($(lift txt') ∷ Ascii) |]
txt' ∷ String
txt' = concat $ intersperse "\x20"
- $ show num : map A.toString phrase
+ $ show num : map cs phrase
import Data.Char
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 Network.URI
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.
-- >>> 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 ∷ ByteString → AsciiBuilder → AsciiBuilder
go bs ab
→ ab ⊕ b2ab x
| otherwise
→ go (BS.tail y)
- (ab ⊕ b2ab x ⊕ A.toAsciiBuilder "\\\"")
+ (ab ⊕ b2ab x ⊕ cs ("\\\"" ∷ Ascii))
b2ab ∷ ByteString → AsciiBuilder
- b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString
+ b2ab = cs ∘ A.unsafeFromByteString
-- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
-- [("aaa", "bbb"), ("ccc", "ddd")]
-- 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
-- "example.com"
uriHost ∷ URI → Host
{-# INLINE uriHost #-}
-uriHost = CI.mk ∘ T.pack ∘ uriRegName ∘ fromJust ∘ uriAuthority
+uriHost = CI.mk ∘ cs ∘ uriRegName ∘ fromJust ∘ uriAuthority
-- |>>> uriPathSegments "http://example.com/foo/bar"
-- ["foo", "bar"]
-- |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)
+getLastModified = (cs <$>) ∘ getModificationTime
--- !ditz.rubyforge.org,2008-03-06/issue
-title: Use convertible whenever appropriate.
+title: Use convertible wherever appropriate.
desc: ""
type: :task
component: Lucu
release: Lucu-1.0
reporter: PHO <pho@cielonegro.org>
-status: :unstarted
+status: :in_progress
disposition:
creation_time: 2011-12-14 14:07:41.367770 Z
references: []
- PHO <pho@cielonegro.org>
- created
- ""
+- - 2011-12-15 00:08:57.500763 Z
+ - PHO <pho@cielonegro.org>
+ - edited title
+ - ""
+- - 2011-12-15 12:42:17.264054 Z
+ - PHO <pho@cielonegro.org>
+ - changed status from unstarted to in_progress
+ - ""
git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Rsrc Monad should be parameterised by phantom types (e.g. Rsrc GET a) to reduce the chance of runtime errors.
+desc: ""
+type: :task
+component: Lucu
+release: Lucu-1.0
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2011-12-16 10:11:08.635552 Z
+references: []
+
+id: e6ec5a54d14cad8f79c456e23e92770fbbd3577e
+log_events:
+- - 2011-12-16 10:11:09.535825 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
import Control.Monad.Unicode
import qualified Data.ByteString.Lazy.Char8 as Lazy
import qualified Data.Collections as C
+import Data.Default
import Data.Monoid.Unicode
import Network
import Network.HTTP.Lucu
import Prelude.Unicode
main ∷ IO ()
-main = let config = defaultConfig { cnfServerPort = "9999" }
+main = let config = def { cnfServerPort = "9999" }
mapper = resourceMap resources ⊕ resourceMap fallbacks
resources ∷ ResourceTree
resources = C.fromList
UnicodeSyntax
#-}
import qualified Data.Collections as C
+import Data.Default
import MiseRafturai
import Network
import Network.HTTP.Lucu
import Prelude.Unicode
main ∷ IO ()
-main = let config = defaultConfig { cnfServerPort = "9999" }
+main = let config = def { cnfServerPort = "9999" }
tree ∷ ResourceTree
tree = C.fromList [ ([], nonGreedy miseRafturai) ]
in
UnicodeSyntax
#-}
import qualified Data.Collections as C
+import Data.Default
import Network
import Network.HTTP.Lucu
import Prelude.Unicode
import SmallFile
main ∷ IO ()
-main = let config = defaultConfig { cnfServerPort = "9999" }
+main = let config = def { cnfServerPort = "9999" }
tree ∷ ResourceTree
tree = C.fromList [ ([], nonGreedy smallFile) ]
in
import Control.Applicative
import qualified Data.Collections as C
import Control.Monad.Unicode
+import Data.Default
import Data.Maybe
import Data.Monoid.Unicode
import Network
import Text.Blaze.Renderer.Utf8
main ∷ IO ()
-main = let config = defaultConfig { cnfServerPort = "9999" }
+main = let config = def { cnfServerPort = "9999" }
tree ∷ ResourceTree
tree = C.fromList [ ([], nonGreedy resMain) ]
in
let text = fromMaybe (∅) $ fdContent <$> lookup "text" f
file = fromMaybe (∅) $ fdContent <$> lookup "file" f
fileName = fdFileName =≪ lookup "file" f
- setContentType $ parseMIMEType "text/plain"
+ setContentType [mimeType| text/plain |]
putChunks $ "You entered \"" ⊕ text ⊕ "\".\n"
putChunks $ "You uploaded a " ⊕ Lazy.pack (show $ Lazy.length file) ⊕ " bytes long file.\n"
putChunks $ "The file name is " ⊕ Lazy.pack (show fileName) ⊕ ".\n"
import Control.Monad.Unicode
import qualified Data.ByteString.Lazy.Char8 as Lazy
import qualified Data.Collections as C
+import Data.Default
import Data.Time.Clock
import Network
import Network.HTTP.Lucu
SSL.contextSetCertificate ctx cert
SSL.contextSetDefaultCiphers ctx
- let config = defaultConfig {
+ let config = def {
cnfServerPort = "9000"
, cnfSSLConfig = Just SSLConfig {
sslServerPort = "9001"
projects / Lucu.git / commitdiff