From d658442d22fc79829372b79be5b2baf94c151ca5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Sat, 26 Sep 2020 19:32:50 +0200
Subject: [PATCH] Remove Configurator dependency
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>
---
hikaru.cabal | 4 +---
lib/Hikaru/Action.hs | 47 +++++++++++++++++++++++++++++++-------------
lib/Hikaru/CSRF.hs | 11 ++++++++---
package.yaml | 1 -
4 files changed, 42 insertions(+), 21 deletions(-)
diff --git a/hikaru.cabal b/hikaru.cabal
index b87781b..6a41019 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
--- hash: e297323a7b6cecac97f8dd18ae01703782f331a12328a6934ad0a62d7cb0daf3
+-- hash: 5ac50160b1396ef3e336b16f172ed703e020f37d729d4384049493c620bd5167
name: hikaru
version: 0.1.0.0
@@ -55,7 +55,6 @@ 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,7 +93,6 @@ 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 d13e91d..107b35f 100644
--- a/lib/Hikaru/Action.hs
+++ b/lib/Hikaru/Action.hs
@@ -89,6 +89,8 @@ module Hikaru.Action
, dropCaches
-- ** Configuration
+ , updateConfig
+ , updateConfigFromEnv
, getConfigMaybe
, getConfigDefault
@@ -108,8 +110,6 @@ where
import qualified Data.ByteString as BS
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
@@ -128,6 +128,7 @@ where
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status
import Network.Wai
+ import System.Environment
import System.IO.Unsafe
import Web.Cookie
@@ -194,7 +195,7 @@ where
data ActionEnv
= ActionEnv
{ aeRequest :: Request
- , aeConfig :: Cfg.Config
+ , aeConfig :: IORef (Map.Map Text String)
, aeBody :: IORef RequestBody
, aeRespStatus :: IORef Status
, aeRespHeaders :: IORef ResponseHeaders
@@ -264,10 +265,10 @@ where
-- |
-- Create the initial action environment from the 'Request'.
--
- makeActionEnv :: Cfg.Config -> Request -> IO ActionEnv
- makeActionEnv cfg req =
+ makeActionEnv :: Request -> IO ActionEnv
+ makeActionEnv req =
ActionEnv <$> pure req
- <*> pure cfg
+ <*> newIORef Map.empty
<*> newIORef BodyUnparsed
<*> newIORef status200
<*> newIORef []
@@ -1095,24 +1096,42 @@ where
-- Configuration -----------------------------------------------------------
+ -- |
+ -- Update configuration using supplied key-value pairs.
+ --
+ -- Request starts with an empty configuration.
+ --
+ updateConfig :: (MonadAction m) => [(Text, String)] -> m ()
+ updateConfig = modifyActionField aeConfig . Map.union . Map.fromList
+
+
+ -- |
+ -- Update configuration using the program environment.
+ --
+ updateConfigFromEnv :: (MonadAction m) => m ()
+ updateConfigFromEnv = do
+ env <- liftIO $ getEnvironment
+
+ let conv (k, v) = (cs k, v)
+ in updateConfig (map conv env)
+
+
-- |
-- Lookup a configuration value.
--
- getConfigMaybe :: (MonadAction m, Cfg.Configured a) => Text -> m (Maybe a)
+ getConfigMaybe :: (MonadAction m, Read a) => Text -> m (Maybe a)
getConfigMaybe name = do
- cfg <- aeConfig <$> getActionEnv
- liftIO do
- Cfg.lookup cfg name
+ cfg <- getActionField aeConfig
+ return $ readMaybe =<< Map.lookup name cfg
-- |
-- Lookup a configuration value with a fallback to return if not found.
--
- getConfigDefault :: (MonadAction m, Cfg.Configured a) => Text -> a -> m a
+ getConfigDefault :: (MonadAction m, Read a) => Text -> a -> m a
getConfigDefault name value = do
- cfg <- aeConfig <$> getActionEnv
- liftIO do
- Cfg.lookupDefault value cfg name
+ cfg <- getActionField aeConfig
+ return $ fromMaybe value $ readMaybe =<< Map.lookup name cfg
-- Finalizing --------------------------------------------------------------
diff --git a/lib/Hikaru/CSRF.hs b/lib/Hikaru/CSRF.hs
index 52e57c6..c8821eb 100644
--- a/lib/Hikaru/CSRF.hs
+++ b/lib/Hikaru/CSRF.hs
@@ -29,10 +29,12 @@ where
-- |
-- Generate an anti-CSRF token to be used with forms.
--
+ -- Uses the @CSRF_SECRET@ configuration key.
+ --
generateToken :: (MonadAction m) => m Text
generateToken = do
now <- getTimestamp
- secret <- getConfigDefault "csrf.secret" ""
+ secret <- getConfigDefault "CSRF_SECRET" ""
let signature = sign now secret
in return $ mconcat [ show now, ":", signature ]
@@ -41,6 +43,9 @@ where
-- |
-- Verify that the anti-CSRF token is currently valid.
--
+ -- Uses the @CSRF_SECRET@ and @CSRF_VALIDITY@ configuration keys.
+ -- Valididy defaults to 86400 seconds (24 hours).
+ --
isTokenValid :: (MonadAction m) => Text -> m Bool
isTokenValid token = do
case splitOn ":" token of
@@ -48,8 +53,8 @@ where
case readMaybe (cs time) of
Just (timestamp :: Int64) -> do
now <- getTimestamp
- valid <- getConfigDefault "csrf.validity" 86400
- secret <- getConfigDefault "csrf.secret" ""
+ valid <- getConfigDefault "CSRF_VALIDITY" 86400
+ secret <- getConfigDefault "CSRF_SECRET" ""
if timestamp + valid >= now
then return (sign timestamp secret == signature)
diff --git a/package.yaml b/package.yaml
index d493b40..0680073 100644
--- a/package.yaml
+++ b/package.yaml
@@ -49,7 +49,6 @@ 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