From c48d16a4f4311ecdaa0620b39e2334cd57b00e47 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Thu, 18 Jun 2020 01:12:17 +0200
Subject: [PATCH] Integrate with configurator
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
I am still not comfortable with this. Ideally there should not be such a
tight coupling and a different configuration engine could be plugged in
instead. On the other hand, configurator offers environment variable
interpolation, has decent syntax and generally works.
Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>
---
hikaru.cabal | 4 ++-
lib/Hikaru/Action.hs | 62 +++++++++++++++++++++++++++++++++-----------
lib/Hikaru/CSRF.hs | 35 +++++++------------------
lib/Hikaru/Form.hs | 2 +-
package.yaml | 1 +
5 files changed, 62 insertions(+), 42 deletions(-)
diff --git a/hikaru.cabal b/hikaru.cabal
index 0cd8be6..2d65f29 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
--- hash: 29d0cf827300a88d2c302f25025d2f8d70bf6580c115003871c8397c80211d86
+-- hash: abedad9337bb68e5ffcb0364bf2152ac0633c4810698dfc652cd122bedd3290c
name: hikaru
version: 0.1.0.0
@@ -56,6 +56,7 @@ library
, binary >=0.8 && <0.9
, bytestring >=0.10 && <0.11
, case-insensitive >=1.2 && <1.3
+ , configurator >=0.3 && <0.4
, containers >=0.6 && <0.7
, cookie >=0.4 && <0.5
, cryptonite >=0.26 && <0.27
@@ -94,6 +95,7 @@ test-suite spec
, binary >=0.8 && <0.9
, bytestring >=0.10 && <0.11
, case-insensitive >=1.2 && <1.3
+ , configurator >=0.3 && <0.4
, containers >=0.6 && <0.7
, cookie >=0.4 && <0.5
, cryptonite >=0.26 && <0.27
diff --git a/lib/Hikaru/Action.hs b/lib/Hikaru/Action.hs
index ad29fbe..35a3b58 100644
--- a/lib/Hikaru/Action.hs
+++ b/lib/Hikaru/Action.hs
@@ -88,6 +88,10 @@ module Hikaru.Action
, dropCache
, dropCaches
+ -- ** Configuration
+ , getConfigMaybe
+ , getConfigDefault
+
-- ** Finalizing
, registerFinalizer
@@ -103,9 +107,11 @@ where
import BasePrelude hiding (length)
import qualified Data.ByteString.Lazy as LBS
+ import qualified Data.Configurator as Cfg
+ import qualified Data.Configurator.Types as Cfg
+ import qualified Data.Map.Strict as Map
import qualified Data.Text.Lazy as LT
import qualified Network.Wai.Parse as Parse
- import qualified Data.Map.Strict as Map
import Control.Monad.Trans
import Control.Monad.Trans.Resource
@@ -186,6 +192,7 @@ where
data ActionEnv
= ActionEnv
{ aeRequest :: Request
+ , aeConfig :: Cfg.Config
, aeBody :: IORef RequestBody
, aeRespStatus :: IORef Status
, aeRespHeaders :: IORef ResponseHeaders
@@ -205,9 +212,9 @@ where
--
-- Whole operation is bracketed to ensure all finalizers are run.
--
- respond :: (ActionEnv -> IO ()) -> Application
- respond run req resp = do
- env <- makeActionEnv req
+ respond :: (ActionEnv -> IO ()) -> Cfg.Config -> Application
+ respond run cfg req resp = do
+ env <- makeActionEnv cfg req
bracket_ (return ()) (finalize env) do
_ <- run env
@@ -255,17 +262,19 @@ where
-- |
-- Create the initial action environment from the 'Request'.
--
- makeActionEnv :: Request -> IO ActionEnv
- makeActionEnv req = ActionEnv <$> pure req
- <*> newIORef BodyUnparsed
- <*> newIORef status200
- <*> newIORef []
- <*> newIORef (\st hs -> responseLBS st hs "")
- <*> newIORef (return ())
- <*> newIORef (10 * 1024 * 1024)
- <*> newIORef 0
- <*> newIORef []
- <*> newIORef Map.empty
+ makeActionEnv :: Cfg.Config -> Request -> IO ActionEnv
+ makeActionEnv cfg req =
+ ActionEnv <$> pure req
+ <*> pure cfg
+ <*> newIORef BodyUnparsed
+ <*> newIORef status200
+ <*> newIORef []
+ <*> newIORef (\st hs -> responseLBS st hs "")
+ <*> newIORef (return ())
+ <*> newIORef (10 * 1024 * 1024)
+ <*> newIORef 0
+ <*> newIORef []
+ <*> newIORef Map.empty
-- Inspecting Request ------------------------------------------------------
@@ -1081,6 +1090,29 @@ where
modifyActionField aeCache (const Map.empty)
+ -- Configuration -----------------------------------------------------------
+
+
+ -- |
+ -- Lookup a configuration value.
+ --
+ getConfigMaybe :: (MonadAction m, Cfg.Configured a) => Text -> m (Maybe a)
+ getConfigMaybe name = do
+ cfg <- aeConfig <$> getActionEnv
+ liftIO do
+ Cfg.lookup cfg name
+
+
+ -- |
+ -- Lookup a configuration value with a fallback to return if not found.
+ --
+ getConfigDefault :: (MonadAction m, Cfg.Configured a) => Text -> a -> m a
+ getConfigDefault name value = do
+ cfg <- aeConfig <$> getActionEnv
+ liftIO do
+ Cfg.lookupDefault value cfg name
+
+
-- Finalizing --------------------------------------------------------------
diff --git a/lib/Hikaru/CSRF.hs b/lib/Hikaru/CSRF.hs
index f44492a..67fc98c 100644
--- a/lib/Hikaru/CSRF.hs
+++ b/lib/Hikaru/CSRF.hs
@@ -7,18 +7,16 @@ Maintainer : mordae@anilinux.org
Stability : unstable
Portability : non-portable (ghc)
-CSRF mitigation utilities.
+This module provides CSRF mitigation utilities.
-}
module Hikaru.CSRF
- ( MonadCsrf(..)
- , generateToken
+ ( generateToken
, isTokenValid
)
where
import BasePrelude
- import Control.Monad.Trans
import Crypto.Hash
import Crypto.MAC.HMAC
import Data.ByteString (ByteString)
@@ -26,46 +24,33 @@ where
import Data.Text (Text, splitOn)
import Data.Time.Clock.POSIX (getPOSIXTime)
-
- class (MonadIO m) => MonadCsrf m where
- csrfTokenValidity :: m Int64
- csrfTokenSecret :: m Text
-
- default csrfTokenValidity
- :: (MonadTrans t, MonadCsrf n, m ~ t n) => m Int64
- csrfTokenValidity = lift csrfTokenValidity
- {-# INLINE csrfTokenValidity #-}
-
- default csrfTokenSecret
- :: (MonadTrans t, MonadCsrf n, m ~ t n) => m Text
- csrfTokenSecret = lift csrfTokenSecret
- {-# INLINE csrfTokenSecret #-}
+ import Hikaru.Action
-- |
- -- TODO
+ -- Generate an anti-CSRF token to be used with forms.
--
- generateToken :: (MonadCsrf m) => m Text
+ generateToken :: (MonadAction m) => m Text
generateToken = do
now <- getTimestamp
- secret <- csrfTokenSecret
+ secret <- getConfigDefault "csrf.secret" ""
let signature = sign now secret
in return $ mconcat [ cs (show now), ":", signature ]
-- |
- -- TODO
+ -- Verify that the anti-CSRF token is currently valid.
--
- isTokenValid :: (MonadCsrf m) => Text -> m Bool
+ isTokenValid :: (MonadAction m) => Text -> m Bool
isTokenValid token = do
case splitOn ":" token of
[time, signature] -> do
case readMaybe (cs time) of
Just (timestamp :: Int64) -> do
now <- getTimestamp
- valid <- csrfTokenValidity
- secret <- csrfTokenSecret
+ valid <- getConfigDefault "csrf.validity" 86400
+ secret <- getConfigDefault "csrf.secret" ""
if timestamp + valid >= now
then return (sign timestamp secret == signature)
diff --git a/lib/Hikaru/Form.hs b/lib/Hikaru/Form.hs
index b125785..e4d95e3 100644
--- a/lib/Hikaru/Form.hs
+++ b/lib/Hikaru/Form.hs
@@ -625,7 +625,7 @@ where
--
-- TODO: Add an example.
--
- token :: (MonadCsrf m, FromFormMessage l) => Text -> FormT l o m Text
+ token :: (MonadAction m, FromFormMessage l) => Text -> FormT l o m Text
token name =
hiddenValue name (Just <$> generateToken) do
validate \case
diff --git a/package.yaml b/package.yaml
index 6e2a8b8..d697cb7 100644
--- a/package.yaml
+++ b/package.yaml
@@ -49,6 +49,7 @@ dependencies:
- binary >= 0.8 && <0.9
- bytestring >= 0.10 && <0.11
- case-insensitive >= 1.2 && <1.3
+ - configurator >= 0.3 && <0.4
- containers >= 0.6 && <0.7
- cookie >= 0.4 && <0.5
- cryptonite >= 0.26 && <0.27
--
GitLab