From cbb13e474d3ae15378a5fb2fd67501ec7b5157da Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Sun, 27 Sep 2020 15:18:21 +0200
Subject: [PATCH] Redesign configuration handling even more
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 | 9 ++--
lib/Hikaru.hs | 2 +
lib/Hikaru/Action.hs | 74 +++++++++++-------------------
lib/Hikaru/Config.hs | 105 +++++++++++++++++++++++++++++++++++++++++++
package.yaml | 5 ++-
test/Hikaru/Demo.hs | 18 ++++----
6 files changed, 152 insertions(+), 61 deletions(-)
create mode 100644 lib/Hikaru/Config.hs
diff --git a/hikaru.cabal b/hikaru.cabal
index 6a41019..3d892b4 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
--- hash: 5ac50160b1396ef3e336b16f172ed703e020f37d729d4384049493c620bd5167
+-- hash: 8bbf377869281f273f43485c46ccce646be610521dbf18fa016b0762e07d767f
name: hikaru
version: 0.1.0.0
@@ -35,6 +35,7 @@ library
exposed-modules:
Hikaru
Hikaru.Action
+ Hikaru.Config
Hikaru.CSRF
Hikaru.Dispatch
Hikaru.Form
@@ -47,7 +48,7 @@ library
Paths_hikaru
hs-source-dirs:
lib
- default-extensions: BlockArguments DataKinds DefaultSignatures DeriveGeneric FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
+ default-extensions: BlockArguments DataKinds DefaultSignatures DeriveGeneric FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
ghc-options: -Wall -Wcompat
build-depends:
aeson >=1.4 && <1.5
@@ -60,6 +61,7 @@ library
, cryptonite >=0.26 && <0.27
, http-types >=0.12 && <0.13
, lucid >=2.9 && <2.10
+ , memory >=0.15 && <0.16
, mtl >=2.2 && <2.3
, relude >=0.7 && <0.8
, resourcet >=1.2 && <1.3
@@ -82,7 +84,7 @@ test-suite spec
Paths_hikaru
hs-source-dirs:
test
- default-extensions: BlockArguments DataKinds DefaultSignatures DeriveGeneric FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
+ default-extensions: BlockArguments DataKinds DefaultSignatures DeriveGeneric FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N
cpp-options: -DTEST
build-tool-depends:
@@ -100,6 +102,7 @@ test-suite spec
, hspec
, http-types >=0.12 && <0.13
, lucid >=2.9 && <2.10
+ , memory >=0.15 && <0.16
, mtl >=2.2 && <2.3
, relude >=0.7 && <0.8
, resourcet >=1.2 && <1.3
diff --git a/lib/Hikaru.hs b/lib/Hikaru.hs
index 7556292..6e38b2e 100644
--- a/lib/Hikaru.hs
+++ b/lib/Hikaru.hs
@@ -14,6 +14,7 @@ module Hikaru
(
-- * Exported Modules
module Hikaru.Action
+ , module Hikaru.Config
, module Hikaru.CSRF
, module Hikaru.Dispatch
, module Hikaru.Form
@@ -25,6 +26,7 @@ module Hikaru
)
where
import Hikaru.Action
+ import Hikaru.Config
import Hikaru.CSRF
import Hikaru.Dispatch
import Hikaru.Form
diff --git a/lib/Hikaru/Action.hs b/lib/Hikaru/Action.hs
index 107b35f..464625e 100644
--- a/lib/Hikaru/Action.hs
+++ b/lib/Hikaru/Action.hs
@@ -89,8 +89,6 @@ module Hikaru.Action
, dropCaches
-- ** Configuration
- , updateConfig
- , updateConfigFromEnv
, getConfigMaybe
, getConfigDefault
@@ -121,6 +119,7 @@ where
import Data.Dynamic
import Data.List
import Data.String.Conversions
+ import Hikaru.Config
import Hikaru.Media
import Hikaru.Types
import Lucid
@@ -128,7 +127,6 @@ where
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status
import Network.Wai
- import System.Environment
import System.IO.Unsafe
import Web.Cookie
@@ -195,7 +193,7 @@ where
data ActionEnv
= ActionEnv
{ aeRequest :: Request
- , aeConfig :: IORef (Map.Map Text String)
+ , aeConfig :: Config
, aeBody :: IORef RequestBody
, aeRespStatus :: IORef Status
, aeRespHeaders :: IORef ResponseHeaders
@@ -215,9 +213,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 :: Config -> (ActionEnv -> IO ()) -> Application
+ respond cfg run req resp = do
+ env <- makeActionEnv cfg req
bracket_ (return ()) (finalize env) do
_ <- run env
@@ -263,21 +261,23 @@ where
-- |
- -- Create the initial action environment from the 'Request'.
+ -- Create an initial action environment to handle given 'Request'.
--
- makeActionEnv :: Request -> IO ActionEnv
- makeActionEnv req =
- ActionEnv <$> pure req
- <*> newIORef Map.empty
- <*> newIORef BodyUnparsed
- <*> newIORef status200
- <*> newIORef []
- <*> newIORef (\st hs -> responseLBS st hs "")
- <*> newIORef (return ())
- <*> newIORef (10 * 1024 * 1024)
- <*> newIORef 0
- <*> newIORef []
- <*> newIORef Map.empty
+ makeActionEnv :: Config -> Request -> IO ActionEnv
+ makeActionEnv cfg req = do
+ aeRequest <- pure req
+ aeConfig <- pure cfg
+ aeBody <- newIORef BodyUnparsed
+ aeRespStatus <- newIORef status200
+ aeRespHeaders <- newIORef []
+ aeRespMaker <- newIORef (\st hs -> responseLBS st hs "")
+ aeFinalize <- newIORef (return ())
+ aeBodyLimit <- newIORef (10 * 1024 * 1024)
+ aeBodyCounter <- newIORef 0
+ aeLanguages <- newIORef []
+ aeCache <- newIORef Map.empty
+
+ return ActionEnv{..}
-- Inspecting Request ------------------------------------------------------
@@ -1096,42 +1096,22 @@ 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, Read a) => Text -> m (Maybe a)
+ getConfigMaybe :: (MonadAction m, Param a) => Text -> m (Maybe a)
getConfigMaybe name = do
- cfg <- getActionField aeConfig
- return $ readMaybe =<< Map.lookup name cfg
+ ActionEnv{aeConfig} <- getActionEnv
+ return $ fromParam =<< Map.lookup name aeConfig
-- |
-- Lookup a configuration value with a fallback to return if not found.
--
- getConfigDefault :: (MonadAction m, Read a) => Text -> a -> m a
+ getConfigDefault :: (MonadAction m, Param a) => Text -> a -> m a
getConfigDefault name value = do
- cfg <- getActionField aeConfig
- return $ fromMaybe value $ readMaybe =<< Map.lookup name cfg
+ ActionEnv{aeConfig} <- getActionEnv
+ return $ fromMaybe value $ fromParam =<< Map.lookup name aeConfig
-- Finalizing --------------------------------------------------------------
diff --git a/lib/Hikaru/Config.hs b/lib/Hikaru/Config.hs
new file mode 100644
index 0000000..fb297e6
--- /dev/null
+++ b/lib/Hikaru/Config.hs
@@ -0,0 +1,105 @@
+{-|
+Module : Hikaru.Config
+Copyright : Jan Hamal Dvořák
+License : AGPL-3
+
+Maintainer : mordae@anilinux.org
+Stability : unstable
+Portability : non-portable (ghc)
+
+This module provides means to read configuration from environment and files.
+
+Example:
+
+@
+ base <- 'configDefault'
+ file <- 'configFromFile' \"site.env\"
+ env <- 'configFromEnv'
+
+ let cfg = env <> file <> base
+@
+-}
+
+module Hikaru.Config
+ ( Config
+ , configFromEnv
+ , configFromFile
+ , configDefault
+
+ -- * Secrets
+ , generateSecret
+ )
+where
+ import Relude hiding (lines)
+
+ import qualified Data.Map as Map
+
+ import Crypto.Random.Entropy
+ import Data.ByteArray.Encoding
+ import Data.List (lines, span)
+ import Data.String.Conversions
+ import System.Environment
+
+
+ -- |
+ -- Website configuration to be passed to the action.
+ --
+ type Config = Map.Map Text Text
+
+
+ -- |
+ -- Read configuration from program environment.
+ --
+ configFromEnv :: (MonadIO m) => m Config
+ configFromEnv = Map.fromList <$> map conv <$> liftIO getEnvironment
+ where conv (k, v) = (cs k, cs v)
+
+
+ -- |
+ -- Read configuration from file.
+ --
+ -- To read configuration from a file and then update it from the environment
+ -- use "<>" like this:
+ --
+ -- @
+ -- def <- 'configFromFile' \"site.env\"
+ -- env <- 'configFromEnv'
+ --
+ -- let cfg = env <> def
+ -- @
+ --
+ configFromFile :: (MonadIO m) => FilePath -> m Config
+ configFromFile path = Map.fromList <$> map parse <$> lines <$> readFile path
+ where
+ parse = conv . span (/= '=')
+ conv (k, v) = (cs k, cs $ drop 1 v)
+
+
+ -- |
+ -- Generate default configuration with keys required by Hikaru.
+ --
+ -- This includes @CSRF_SECRET@ which should be set to something persistent,
+ -- but if it's not, it must be set to a random value upon startup at least.
+ --
+ configDefault :: (MonadIO m) => m Config
+ configDefault = do
+ secret <- generateSecret 16
+
+ return $ Map.fromList [ ("CSRF_SECRET", secret)
+ , ("CSRF_VALIDITY", "86400")
+ ]
+
+
+ -- |
+ -- Generate a random base64-encoded secret of given length
+ -- (in decoded bytes).
+ --
+ generateSecret :: (MonadIO m) => Int -> m Text
+ generateSecret n = do
+ (bstr :: ByteString) <- liftIO $ getEntropy n
+
+ let (bstr64 :: ByteString) = convertToBase Base64 bstr
+ in return (cs bstr64)
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/package.yaml b/package.yaml
index 0680073..c8d9d78 100644
--- a/package.yaml
+++ b/package.yaml
@@ -27,6 +27,7 @@ default-extensions:
- DataKinds
- DefaultSignatures
- DeriveGeneric
+ - FlexibleContexts
- FlexibleInstances
- GADTs
- GeneralizedNewtypeDeriving
@@ -45,7 +46,6 @@ default-extensions:
dependencies:
- aeson >= 1.4 && <1.5
- base >= 4.13 && <4.14
- - relude >= 0.7 && <0.8
- binary >= 0.8 && <0.9
- bytestring >= 0.10 && <0.11
- case-insensitive >= 1.2 && <1.3
@@ -54,7 +54,9 @@ dependencies:
- cryptonite >= 0.26 && <0.27
- http-types >= 0.12 && <0.13
- lucid >= 2.9 && <2.10
+ - memory >= 0.15 && <0.16
- mtl >= 2.2 && <2.3
+ - relude >= 0.7 && <0.8
- resourcet >= 1.2 && <1.3
- string-conversions >= 0.4 && <0.5
- text >= 1.2 && <1.3
@@ -70,6 +72,7 @@ library:
exposed-modules:
- Hikaru
- Hikaru.Action
+ - Hikaru.Config
- Hikaru.CSRF
- Hikaru.Dispatch
- Hikaru.Form
diff --git a/test/Hikaru/Demo.hs b/test/Hikaru/Demo.hs
index 437b7b1..1510455 100644
--- a/test/Hikaru/Demo.hs
+++ b/test/Hikaru/Demo.hs
@@ -100,24 +100,22 @@ where
makeDemo :: IO Application
makeDemo = do
model <- makeModelEnv 0
- return $ makeApplication model
+ cfg <- configFromEnv
+ return $ makeApplication model cfg
- runAction :: ModelEnv -> Action () -> Application
- runAction me act = do
- respond \ae -> do
+ runAction :: ModelEnv -> Config -> Action () -> Application
+ runAction me cfg act = do
+ respond cfg \ae -> do
runReaderT (unAction act) (DemoEnv ae me)
- makeApplication :: ModelEnv -> Application
- makeApplication me = do
- dispatch (runAction me) do
+ makeApplication :: ModelEnv -> Config -> Application
+ makeApplication me cfg = do
+ dispatch (runAction me cfg) do
-- Register nicer 404 error handler.
handler NotFound handleNotFound
- -- Read configuration from environment.
- wrapActions (updateConfigFromEnv >>)
-
-- Negotiate content for the root page.
route $ getRootHtmlR <$ get <* offerHTML
route $ getRootTextR <$ get <* offerText
--
GitLab