Skip to content
Snippets Groups Projects
Verified Commit 8ff7ce43 authored by jan.hamal.dvorak's avatar jan.hamal.dvorak
Browse files

Drop Hikaru.Config and use Praha.Config instead 


Signed-off-by: default avatarJan Hamal Dvořák <mordae@anilinux.org>
parent 76e4fe27
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
hikaru.cabal
+ 1
− 1
View file @ 8ff7ce43
......@@ -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
+ 0
− 2
View file @ 8ff7ce43
......@@ -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
+ 5
− 33
View file @ 8ff7ce43
......@@ -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
+ 35
− 2
View file @ 8ff7ce43
......@@ -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 deleted 100644 → 0
+ 0
− 150
View file @ 76e4fe27
--
-- 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:
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment

Pirátský GitLab - Home of the CopyLeft