X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FAuthorization.hs;h=789b5d1c971dfba93f0612e46d1fe79b86fdc9ad;hb=6126eb9;hp=8e1be587e9c4f25c93f2e581db594e249972d96f;hpb=9ac730212cb361eb10e5fe4ad0eec6758e2b200a;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs
index 8e1be58..789b5d1 100644
--- a/Network/HTTP/Lucu/Authorization.hs
+++ b/Network/HTTP/Lucu/Authorization.hs
@@ -1,4 +1,7 @@
-{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE
+    OverloadedStrings
+  , UnicodeSyntax
+  #-}
 
 -- |Manipulation of WWW authorization.
 module Network.HTTP.Lucu.Authorization
@@ -8,60 +11,69 @@ module Network.HTTP.Lucu.Authorization
     , UserID
     , Password
 
-    , authCredentialP -- private
+    , printAuthChallenge
+    , authCredentialP
     )
     where
-
-import qualified Codec.Binary.Base64 as B64
-import           Data.Maybe
-import           Network.HTTP.Lucu.Parser
-import           Network.HTTP.Lucu.Parser.Http
-import           Network.HTTP.Lucu.Utils
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8 as C8
+import Data.Monoid.Unicode
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
 
 -- |Authorization challenge to be sent to client with
 -- \"WWW-Authenticate\" header. See
 -- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'.
 data AuthChallenge
-    = BasicAuthChallenge Realm
+    = BasicAuthChallenge !Realm
       deriving (Eq)
 
 -- |'Realm' is just a string which must not contain any non-ASCII letters.
-type Realm = String    
+type Realm = Ascii
 
 -- |Authorization credential to be sent by client with
 -- \"Authorization\" header. See
 -- 'Network.HTTP.Lucu.Resource.getAuthorization'.
 data AuthCredential
-    = BasicAuthCredential UserID Password
+    = BasicAuthCredential !UserID !Password
       deriving (Show, Eq)
 
 -- |'UserID' is just a string which must not contain colon and any
 -- non-ASCII letters.
-type UserID   = String
+type UserID   = Ascii
 
 -- |'Password' is just a string which must not contain any non-ASCII
 -- letters.
-type Password = String
-
+type Password = Ascii
 
-instance Show AuthChallenge where
-    show (BasicAuthChallenge realm)
-        = "Basic realm=" ++ quoteStr realm
+-- |Convert an 'AuthChallenge' to 'Ascii'.
+printAuthChallenge ∷ AuthChallenge → Ascii
+printAuthChallenge (BasicAuthChallenge realm)
+    = A.fromAsciiBuilder $
+      A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm
 
+authCredentialP ∷ Parser AuthCredential
+authCredentialP
+    = do _ ← 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+/="
 
-authCredentialP :: Parser AuthCredential
-authCredentialP = allowEOF $!
-                  do _   <- string "Basic"
-                     _   <- many1 lws
-                     b64 <- many1
-                            $ satisfy (\ c -> (c >= 'a' && c <= 'z') ||
-                                              (c >= 'A' && c <= 'Z') ||
-                                              (c >= '0' && c <= '9') ||
-                                              c == '+' ||
-                                              c == '/' ||
-                                              c == '=')
-                     let decoded = map (toEnum . fromEnum) (fromJust $ B64.decode b64)
-                     case break (== ':') decoded of
-                       (uid, ':' : password)
-                           -> return (BasicAuthCredential uid password)
-                       _   -> failP
+      asc ∷ C8.ByteString → Parser Ascii
+      asc bs = case A.fromByteString bs of
+                 Just as → return as
+                 Nothing → fail "Non-ascii character in auth credential"