Authorization

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs
index d085234b5e1b4cf8c7c71cae9a10bb059c167a7c..6472fb4e6ce6f5668a35382dc20d13defbb32a82 100644 (file)
--- a/Network/HTTP/Lucu/Authorization.hs
+++ b/Network/HTTP/Lucu/Authorization.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
-    UnicodeSyntax
+    OverloadedStrings
+  , UnicodeSyntax
   #-}
 {-# OPTIONS_HADDOCK prune #-}
 
@@ -11,13 +12,17 @@ module Network.HTTP.Lucu.Authorization
     , UserID
     , Password
 
+    , printAuthChallenge
     , authCredentialP -- private
     )
     where
 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.Maybe
+import Data.Monoid.Unicode
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils
 import Prelude.Unicode
@@ -47,27 +52,27 @@ type UserID   = Ascii
 -- letters.
 type Password = Ascii
 
--- FIXME: Don't use String for network output.
-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
-    = 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 ≡ '=')
-         case break (≡ ':') (decode b64) of
-           (uid, ':' : password)
-               → return (BasicAuthCredential uid password)
-           _   → failP
+    = try $
+      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
+                   → let u = fromJust $ A.fromByteString user
+                         p = fromJust $ A.fromByteString (C8.tail cPassword)
+                     in
+                       return (BasicAuthCredential u p)
     where
-      decode ∷ String → String
-      decode = C8.unpack ∘ B64.decodeLenient ∘ C8.pack
+      base64 ∷ Char → Bool
+      base64 = inClass "a-zA-Z0-9+/="