Drop Hikaru.Config and use Praha.Config instead

Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>

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

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

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 --------------------------------------------------------------
 
 

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:

lib/Hikaru/Config.hs

---
--- 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: