Code clean-up using convertible-text

Ditz-issue: 0a2a377be55430e655ab42fdc4902fa56a058b26

diff --git a/Lucu.cabal b/Lucu.cabal
index c033bb4fdc1e29134a4155f6902bb3b39b47279e..00f309133b8fbfef854a475d737b64eaa3d2177f 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -63,7 +63,9 @@ Library
         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.*,

diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs
index 6a827d08412253cf9f5cfc06fab5703b4f6bf2da..a3f73bef3529e85092f139efa9d88d89a4a1bb57 100644 (file)
--- a/Network/HTTP/Lucu.hs
+++ b/Network/HTTP/Lucu.hs
@@ -59,7 +59,6 @@ module Network.HTTP.Lucu
     , ETag(..)
     , strongETag
     , weakETag
-    , parseETag
 
       -- *** MIME Type
     , MIMEType(..)

diff --git a/Network/HTTP/Lucu/Authentication.hs b/Network/HTTP/Lucu/Authentication.hs
index 29ae0e92bc1b9752850a7ce8dd342df78fa6203a..69223f2e1bb82c878c2f1174cc007a44a850f90e 100644 (file)
--- a/Network/HTTP/Lucu/Authentication.hs
+++ b/Network/HTTP/Lucu/Authentication.hs
@@ -1,5 +1,8 @@
 {-# LANGUAGE
-    OverloadedStrings
+    FlexibleInstances
+  , MultiParamTypeClasses
+  , OverloadedStrings
+  , TemplateHaskell
   , UnicodeSyntax
   #-}
 -- |An internal module for HTTP authentication.
@@ -9,17 +12,18 @@ module Network.HTTP.Lucu.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
@@ -47,11 +51,18 @@ type UserID = Ascii
 -- |'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
@@ -72,6 +83,6 @@ 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"

diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs
index 7a2d81f96586972b1cdc3bbd3969576a8ae92d10..366a63cb1aab9bad37f96cd9eb4f5d701fff01e6 100644 (file)
--- a/Network/HTTP/Lucu/Config.hs
+++ b/Network/HTTP/Lucu/Config.hs
@@ -9,12 +9,12 @@ module Network.HTTP.Lucu.Config
 #if defined(HAVE_SSL)
     , SSLConfig(..)
 #endif
-    , defaultConfig
     )
     where
 import Data.Ascii (Ascii)
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
+import Data.Default
 import Data.Text (Text)
 import qualified Data.Text as T
 import Network
@@ -105,19 +105,18 @@ data SSLConfig
 -- |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 ∘ T.pack $ 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
+          }

diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs
index 08c10602174cca93d03da0bc6e6540afb03574da..3ebfc1d91b35b3f7e676571d0ed981a813b67dbf 100644 (file)
--- a/Network/HTTP/Lucu/ETag.hs
+++ b/Network/HTTP/Lucu/ETag.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE
     DeriveDataTypeable
+  , FlexibleInstances
+  , MultiParamTypeClasses
   , OverloadedStrings
   , RecordWildCards
   , TemplateHaskell
@@ -8,8 +10,6 @@
 -- |An internal module for entity tags.
 module Network.HTTP.Lucu.ETag
     ( ETag(..)
-    , parseETag
-    , printETag
 
     , strongETag
     , weakETag
@@ -20,13 +20,14 @@ module Network.HTTP.Lucu.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
@@ -50,26 +51,24 @@ instance Lift ETag where
              }
            |]
 
--- |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)
 
--- |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)
+instance ConvertSuccess ETag AsciiBuilder where
+    {-# INLINE convertSuccess #-}
+    convertSuccess (ETag {..})
+        = ( if etagIsWeak then
+                cs ("W/" ∷ Ascii)
+            else
+                (∅)
+          )
+          ⊕
+          quoteStr etagToken
+
+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

diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs
index f5376f1267631f0aa82faf378c5fb52069d0d975..51c2de104cf807d4bf44712e337c2fdaef405567 100644 (file)
--- a/Network/HTTP/Lucu/Implant/PrettyPrint.hs
+++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs
@@ -19,6 +19,7 @@ import qualified Data.Ascii as A
 import qualified Data.ByteString.Lazy as L
 import Data.Char
 import Data.Collections
+import Data.Convertible.Base
 import Data.List (intersperse)
 import Data.Monoid
 import Data.Ratio
@@ -68,7 +69,7 @@ header i@(Input {..})
            ]
     where
       eTagToDoc ∷ ETag → Doc
-      eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag
+      eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ cs
 
       mimeTypeToDoc ∷ MIMEType → Doc
       mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 5c45ace0d88c960e750ddd152f18830c3fbeb7b8..6f3ecce8b851e8526e1f5eb48f6bf255656533ab 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -380,7 +380,7 @@ foundETag tag
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "ETag"
              $ A.fromAsciiBuilder
-             $ printETag tag
+             $ cs tag
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
@@ -670,7 +670,7 @@ setContentEncoding codings
 -- |@'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