From 3d4b8e20128188defe967874dd707bd5f08163fd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Thu, 27 May 2021 01:13:30 +0200
Subject: [PATCH] Add rudimentary support for Basic Authorization
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>
---
lib/Hikaru/Action.hs | 38 +++++++++++++++++++++++++++++++++-----
1 file changed, 33 insertions(+), 5 deletions(-)
diff --git a/lib/Hikaru/Action.hs b/lib/Hikaru/Action.hs
index 9bb657e..fb28354 100644
--- a/lib/Hikaru/Action.hs
+++ b/lib/Hikaru/Action.hs
@@ -20,6 +20,7 @@ module Hikaru.Action
, getHeaders
, getHeaderMaybe
, getHeaderDefault
+ , getBasicAuth
, getAccept
, getAcceptCharset
, getAcceptEncoding
@@ -118,9 +119,11 @@ where
import qualified Network.Wai.Parse as Parse
import Control.Monad.Trans.Resource
- import UnliftIO
import Data.Aeson
import Data.Binary.Builder
+ import Data.ByteArray.Encoding
+ import Data.ByteString.Char8 (words, span, drop)
+ import Data.CaseInsensitive (mk)
import Data.Dynamic
import Data.List (deleteBy, lookup, map, filter)
import Hikaru.Media
@@ -132,6 +135,7 @@ where
import Network.Wai
import Network.Wai.Handler.WebSockets
import System.IO.Unsafe
+ import UnliftIO
import Web.Cookie
import qualified Network.WebSockets as WS
@@ -227,11 +231,11 @@ where
bracket_ (return ()) (finalize env) do
_ <- run env
- st <- readIORef $ aeRespStatus $ env
- hs <- readIORef $ aeRespHeaders $ env
- mk <- readIORef $ aeRespMaker $ env
+ status <- readIORef $ aeRespStatus $ env
+ headers <- readIORef $ aeRespHeaders $ env
+ make <- readIORef $ aeRespMaker $ env
- resp (mk st hs)
+ resp (make status headers)
where
finalize :: ActionEnv -> IO ()
@@ -329,6 +333,14 @@ where
getHeaderDefault n v = fromMaybe v <$> getHeaderMaybe n
+ -- |
+ -- Obtain the login and password pair from the Authorization
+ -- request header, if present.
+ --
+ getBasicAuth :: (MonadAction m) => m (Maybe (Text, Text))
+ getBasicAuth = (parseBasicAuth =<<) <$> getHeaderMaybe "Authorization"
+
+
-- |
-- Obtain the Accept header value or the default value of @\"*/*\"@.
--
@@ -1262,4 +1274,20 @@ where
cs2 (x, y) = (cs x, cs y)
+ decodeBase64 :: ByteString -> Either String ByteString
+ decodeBase64 bstr = convertFromBase Base64 bstr
+
+
+ parseBasicAuth :: ByteString -> Maybe (Text, Text)
+ parseBasicAuth value =
+ case words value of
+ [method, auth] | mk method == "Basic" -> do
+ case decodeBase64 auth of
+ Left _ -> Nothing
+ Right lp -> let (l, p) = span (/= ':') lp
+ in Just (cs l, cs (drop 1 p))
+
+ _otherwise -> Nothing
+
+
-- vim:set ft=haskell sw=2 ts=2 et:
--
GitLab