X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FAuthentication.hs;h=c91aa7ea54dfae12364f2dde106aa4c3b4e89dca;hb=db4a546d0d462cb94639b1f273bf0b78bccc960c;hp=3f8d76297169aeaa074c70310d7773af988ddff2;hpb=9668dc27a02b59d7bfb1e9e40af3d2619700ad69;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Authentication.hs b/Network/HTTP/Lucu/Authentication.hs
index 3f8d762..c91aa7e 100644
--- a/Network/HTTP/Lucu/Authentication.hs
+++ b/Network/HTTP/Lucu/Authentication.hs
@@ -1,25 +1,30 @@
 {-# LANGUAGE
-    OverloadedStrings
+    FlexibleInstances
+  , MultiParamTypeClasses
+  , OverloadedStrings
+  , TemplateHaskell
   , UnicodeSyntax
   #-}
--- |HTTP Authentication
+-- |An internal module for HTTP authentication.
 module Network.HTTP.Lucu.Authentication
     ( AuthChallenge(..)
     , AuthCredential(..)
     , Realm
     , UserID
     , Password
-
-    , printAuthChallenge
-    , authCredentialP
     )
     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 Data.Attoparsec.Parsable
 import qualified Data.ByteString.Base64 as B64
+import Data.ByteString (ByteString)
 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
@@ -27,7 +32,7 @@ import Prelude.Unicode
 
 -- |Authentication challenge to be sent to clients with
 -- \"WWW-Authenticate\" header field. See
--- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'.
+-- 'Network.HTTP.Lucu.setWWWAuthenticate'.
 data AuthChallenge
     = BasicAuthChallenge !Realm
       deriving (Eq)
@@ -36,8 +41,7 @@ data AuthChallenge
 type Realm = Ascii
 
 -- |Authorization credential to be sent by client with
--- \"Authorization\" header. See
--- 'Network.HTTP.Lucu.Resource.getAuthorization'.
+-- \"Authorization\" header. See 'Network.HTTP.Lucu.getAuthorization'.
 data AuthCredential
     = BasicAuthCredential !UserID !Password
       deriving (Show, Eq)
@@ -48,31 +52,37 @@ 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)
 
--- |'Parser' for an 'AuthCredential'.
-authCredentialP ∷ Parser AuthCredential
-authCredentialP
-    = do void $ string "Basic"
-         skipMany1 lws
-         b64 ← takeWhile1 base64
-         case C8.break (≡ ':') (B64.decodeLenient b64) of
-           (user, cPassword)
-               | C8.null cPassword
-                   → fail "no colons in the basic auth credential"
-               | otherwise
-                   → do u ← asc user
-                        p ← asc (C8.tail cPassword)
-                        return (BasicAuthCredential u p)
-    where
-      base64 ∷ Char → Bool
-      base64 = inClass "a-zA-Z0-9+/="
+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 |])
+               ]
+
+instance Parsable ByteString AuthCredential where
+    parser = do void $ string "Basic"
+                skipMany1 lws
+                b64 ← takeWhile1 base64
+                case C8.break (≡ ':') (B64.decodeLenient b64) of
+                  (user, cPassword)
+                      | C8.null cPassword
+                          → fail "no colons in the basic auth credential"
+                      | otherwise
+                          → do u ← asc user
+                               p ← asc (C8.tail cPassword)
+                               return (BasicAuthCredential u p)
+        where
+          base64 ∷ Char → Bool
+          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 ∷ C8.ByteString → Parser Ascii
+          asc bs
+              = case ca bs of
+                  Success as → return as
+                  Failure _  → fail "Non-ascii character in auth credential"