http basic authorization header parsing

Sadly servant does not expose this though it also implements it.

diff --git a/P2P/Http/Types.hs b/P2P/Http/Types.hs
index db061a23a8a5fba266132f26e1f842a21867c695..b56f5c75539335746c0365f285643f93c0d82ac7 100644 (file)
--- a/P2P/Http/Types.hs
+++ b/P2P/Http/Types.hs
@@ -21,6 +21,8 @@ import Utility.MonotonicClock
 import Servant
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
+import qualified Data.ByteString as B
+import Data.Char
 import Text.Read (readMaybe)
 import Data.Aeson hiding (Key)
 import Control.DeepSeq
@@ -101,9 +103,28 @@ newtype UnlockRequest = UnlockRequest Bool
 -- Not using servant's build-in basic authentication support,
 -- because whether authentication is needed depends on server
 -- configuration.
-data Auth = Auth T.Text T.Text
+data Auth = Auth B.ByteString B.ByteString
        deriving (Show, Generic, NFData)
 
+instance ToHttpApiData Auth where
+       toHeader (Auth u p) = "Basic " <> toB64 (u <> ":" <> p)
+       toUrlPiece = TE.decodeUtf8Lenient . toHeader
+
+instance FromHttpApiData Auth where
+       parseHeader h =
+               let (b, rest) = B.break (isSpace . chr . fromIntegral) h
+               in if map toLower (decodeBS b) == "basic"
+                       then case fromB64Maybe (B.dropWhile (isSpace . chr . fromIntegral) rest) of
+                               Just v -> case B.split (fromIntegral (ord ':')) v of
+                                       (u:ps) -> Right $
+                                               Auth u (B.intercalate ":" ps)
+                                       _ -> bad
+                               Nothing -> bad
+                       else bad
+         where
+               bad = Left "invalid basic auth header"
+       parseUrlPiece = parseHeader . encodeBS . T.unpack
+
 newtype ConnectionKeepAlive = ConnectionKeepAlive T.Text
 
 connectionKeepAlive :: ConnectionKeepAlive