diff --git a/hikaru.cabal b/hikaru.cabal
index ee6ef198dbcdba29c5982d22d8a7f49f372581be..394387f5e9ac90e7e1d75b6c14d60692a50f35b9 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -81,6 +81,7 @@ common common
, memory >=0.15 && <0.16
, mtl >=2.2 && <2.3
, praha >=0.1 && <0.2
+ , praha-config >=0.1 && <0.2
, resourcet >=1.2 && <1.3
, text >=1.2 && <1.3
, time >=1.9 && <1.12
@@ -98,7 +99,6 @@ library
Hikaru
Hikaru.Develop
Hikaru.Action
- Hikaru.Config
Hikaru.CSRF
Hikaru.Dispatch
Hikaru.Widget
diff --git a/lib/Hikaru.hs b/lib/Hikaru.hs
index 9b4c5876c7756b622f3ad0132c89e723332b00fe..1aeccba8f2bcea10dbc08bff38488f595f2fa914 100644
--- a/lib/Hikaru.hs
+++ b/lib/Hikaru.hs
@@ -14,7 +14,6 @@ module Hikaru
(
-- * Exported Modules
module Hikaru.Action
- , module Hikaru.Config
, module Hikaru.CSRF
, module Hikaru.Develop
, module Hikaru.Dispatch
@@ -27,7 +26,6 @@ module Hikaru
)
where
import Hikaru.Action
- import Hikaru.Config
import Hikaru.CSRF
import Hikaru.Develop
import Hikaru.Dispatch
diff --git a/lib/Hikaru/Action.hs b/lib/Hikaru/Action.hs
index 1d7edbd515855db0ae993a5431c3844fd16982a4..9bb657e3159a763d7cdb9320e156dfd488d93f57 100644
--- a/lib/Hikaru/Action.hs
+++ b/lib/Hikaru/Action.hs
@@ -97,10 +97,6 @@ module Hikaru.Action
, dropCache
, dropCaches
- -- ** Configuration
- , getConfigMaybe
- , getConfigDefault
-
-- ** Finalizing
, registerFinalizer
@@ -127,7 +123,6 @@ where
import Data.Binary.Builder
import Data.Dynamic
import Data.List (deleteBy, lookup, map, filter)
- import Hikaru.Config
import Hikaru.Media
import Hikaru.Types
import Lucid
@@ -204,7 +199,6 @@ where
data ActionEnv
= ActionEnv
{ aeRequest :: Request
- , aeConfig :: Config
, aeBody :: IORef RequestBody
, aeRespStatus :: IORef Status
, aeRespHeaders :: IORef ResponseHeaders
@@ -226,9 +220,9 @@ where
--
-- Whole operation is bracketed to ensure all finalizers are run.
--
- respond :: Config -> (ActionEnv -> IO ()) -> Application
- respond cfg run req resp = do
- env <- makeActionEnv cfg req
+ respond :: (ActionEnv -> IO ()) -> Application
+ respond run req resp = do
+ env <- makeActionEnv req
bracket_ (return ()) (finalize env) do
_ <- run env
@@ -278,10 +272,9 @@ where
-- |
-- Create an initial action environment to handle given 'Request'.
--
- makeActionEnv :: Config -> Request -> IO ActionEnv
- makeActionEnv cfg req = do
+ makeActionEnv :: Request -> IO ActionEnv
+ makeActionEnv req = do
aeRequest <- pure req
- aeConfig <- pure cfg
aeBody <- newIORef BodyUnparsed
aeRespStatus <- newIORef status200
aeRespHeaders <- newIORef []
@@ -1239,27 +1232,6 @@ where
modifyActionField aeCache (const Map.empty)
- -- Configuration -----------------------------------------------------------
-
-
- -- |
- -- Lookup a configuration value.
- --
- getConfigMaybe :: (MonadAction m, Param a) => Text -> m (Maybe a)
- getConfigMaybe name = do
- ActionEnv{aeConfig} <- getActionEnv
- return $ fromParam =<< Map.lookup name aeConfig
-
-
- -- |
- -- Lookup a configuration value with a fallback to return if not found.
- --
- getConfigDefault :: (MonadAction m, Param a) => Text -> a -> m a
- getConfigDefault name value = do
- ActionEnv{aeConfig} <- getActionEnv
- return $ fromMaybe value $ fromParam =<< Map.lookup name aeConfig
-
-
-- Finalizing --------------------------------------------------------------
diff --git a/lib/Hikaru/CSRF.hs b/lib/Hikaru/CSRF.hs
index d7ceacbceb9e3a2baefec719b682e4b8f3280f94..bd980831d7fb9c2b947922d395c10f1943e741dd 100644
--- a/lib/Hikaru/CSRF.hs
+++ b/lib/Hikaru/CSRF.hs
@@ -16,24 +16,29 @@ module Hikaru.CSRF
)
where
import Praha
+ import Praha.Config.Environment
import Crypto.Hash
import Crypto.MAC.HMAC
+ import Crypto.Random.Entropy
+
import Data.Text (splitOn)
import Data.Time.Clock.POSIX (getPOSIXTime)
+ import Data.ByteArray.Encoding
+
import Hikaru.Action
-- |
-- Generate an anti-CSRF token to be used with forms.
--
- -- Uses the @CSRF_SECRET@ configuration key.
+ -- Uses the @HIKARU_SECRET@ configuration key.
--
generateToken :: (MonadAction m) => m Text
generateToken = do
now <- getTimestamp
- secret <- getConfigDefault "CSRF_SECRET" ""
+ secret <- getSecret
let signature = sign now secret
in return $ mconcat [ tshow now, ":", signature ]
@@ -71,6 +76,21 @@ where
getTimestamp = round <$> liftIO getPOSIXTime
+ -- |
+ -- Use the secret from environment or put there an actual one.
+ --
+ getSecret :: (MonadIO m) => m Text
+ getSecret = do
+ maybeSecret <- getConfigMaybe "HIKARU_SECRET"
+
+ case maybeSecret of
+ Just secret -> return secret
+ Nothing -> do
+ secret <- generateSecret 16
+ setConfig "HIKARU_SECRET" secret
+ return secret
+
+
sign :: Int64 -> Text -> Text
sign timestamp secret = tshow $ hmacGetDigest digest
where
@@ -79,4 +99,17 @@ where
timeBytes = cs (show timestamp) :: ByteString
+ -- |
+ -- 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/lib/Hikaru/Config.hs b/lib/Hikaru/Config.hs
deleted file mode 100644
index a52c981b4d35a54f9665996e0b1bac2f09c11bbd..0000000000000000000000000000000000000000
--- a/lib/Hikaru/Config.hs
+++ /dev/null
@@ -1,150 +0,0 @@
---
--- Module : Hikaru.Config
--- Copyright : Jan Hamal Dvořák
--- License : AGPL-3.0-or-later
---
--- 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
-
- -- * Reading Config
- , configGet
- , configGetMaybe
- , configGetDefault
-
- -- * Secrets
- , generateSecret
- )
-where
- import Praha
-
- import Hikaru.Types
-
- import UnliftIO.Environment
- import Crypto.Random.Entropy
- import Data.ByteArray.Encoding
-
- import Data.Text (lines, strip, drop, span, isPrefixOf)
- import Data.Text.IO (readFile)
- import Data.List (map)
-
- import qualified Data.Map as Map
-
-
- -- |
- -- 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 <$> 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
- -- @
- --
- -- Configuration file format is approximately this:
- --
- -- @
- -- # How many seconds before forms need to be reloaded?
- -- CSRF_VALIDITY = 3600
- --
- -- # Secret key to protect against CSRF. Don't tell anyone!
- -- CSRF_SECRET = Ain9eec8aighoiri
- -- @
- --
- configFromFile :: (MonadIO m) => FilePath -> m Config
- configFromFile path = Map.fromList <$> parseFile <$> contents
- where
- contents = liftIO (readFile path)
- parseFile = mapMaybe parseLine . lines
- parseLine = fmap tidy . fmap parseKV . reject . strip
- parseKV = fmap (drop 1) . span (/= '=')
- reject = guarded (not . isPrefixOf "#") <=< guarded ("" /=)
- tidy (k, v) = (strip k, strip 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")
- ]
-
-
- -- |
- -- Obtain value of a configuration key or raise an error.
- -- You really should not use this function, you know?
- --
- configGet :: (Param a) => Text -> Config -> a
- configGet name cfg = case configGetMaybe name cfg of
- Just value -> value
- Nothing -> error (cs name <> " not set!")
-
-
- -- |
- -- Try to obtain value of a configuration key.
- --
- configGetMaybe :: (Param a) => Text -> Config -> Maybe a
- configGetMaybe name cfg = fromParam =<< Map.lookup name cfg
-
-
- -- |
- -- Obtain value of a configuration key or the provided default.
- --
- configGetDefault :: (Param a) => Text -> a -> Config -> a
- configGetDefault name value = fromMaybe value . configGetMaybe name
-
-
- -- |
- -- 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: