diff --git a/hikaru.cabal b/hikaru.cabal
index 1624ede06a33853e7cab03fd64d06df2aec8efbb..31cadfff8c6c1f66262e323cbec885e402d991ca 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
--- hash: 00d0ac3f76ad05002c67411c92f1e77aeee6a21668bc86d354917560a1f0ae2f
+-- hash: 909aa9806ed1dc9c21215c17ba94cb4e184959ac38e8f35cef2091f7639d4f52
name: hikaru
version: 0.1.0.0
@@ -35,6 +35,7 @@ library
exposed-modules:
Hikaru
Hikaru.Action
+ Hikaru.CSRF
Hikaru.Dispatch
Hikaru.Form
Hikaru.Link
@@ -46,7 +47,7 @@ library
Paths_hikaru
hs-source-dirs:
lib
- default-extensions: BlockArguments DeriveGeneric FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving DataKinds
+ default-extensions: BlockArguments DefaultSignatures FlexibleInstances GeneralizedNewtypeDeriving GADTs LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving
ghc-options: -Wall -Wcompat
build-depends:
aeson >=1.4 && <1.5
@@ -57,6 +58,7 @@ library
, case-insensitive >=1.2 && <1.3
, containers >=0.6 && <0.7
, cookie >=0.4 && <0.5
+ , cryptonite >=0.25 && <0.26
, http-types >=0.12 && <0.13
, lucid >=2.9 && <2.10
, mtl >=2.2 && <2.3
@@ -64,6 +66,7 @@ library
, string-conversions >=0.4 && <0.5
, text >=1.2 && <1.3
, text-icu >=0.7 && <0.8
+ , time >=1.8 && <1.9
, wai >=3.2 && <3.3
, wai-extra >=3.0 && <3.1
default-language: Haskell2010
diff --git a/lib/Hikaru/Action.hs b/lib/Hikaru/Action.hs
index c1fd2cf62498dadad5316926bc9cd7136e8ddc68..8b4bd5543b08ad87f7612c1186bd48a842acd75b 100644
--- a/lib/Hikaru/Action.hs
+++ b/lib/Hikaru/Action.hs
@@ -101,7 +101,7 @@ where
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text.Lazy as LT
- import Control.Monad.Trans (lift)
+ import Control.Monad.Trans
import Control.Monad.Trans.Resource
import Data.Aeson (Value, ToJSON, encode, eitherDecode')
import Data.Binary.Builder
@@ -137,11 +137,14 @@ where
--
getActionEnv :: m ActionEnv
+ default getActionEnv
+ :: (MonadTrans t, MonadAction n, m ~ t n) => m ActionEnv
+ getActionEnv = lift getActionEnv
+
-- |
-- Allow access to action when building HTML responses.
--
- instance (MonadAction m) => MonadAction (HtmlT m) where
- getActionEnv = lift getActionEnv
+ instance (MonadAction m) => MonadAction (HtmlT m)
-- |
diff --git a/lib/Hikaru/CSRF.hs b/lib/Hikaru/CSRF.hs
new file mode 100644
index 0000000000000000000000000000000000000000..73b195637a5577a5f8b9af07755626d8196b22d2
--- /dev/null
+++ b/lib/Hikaru/CSRF.hs
@@ -0,0 +1,93 @@
+{-|
+Module : Hikaru.CSRF
+Copyright : Jan Hamal Dvořák
+License : AGPL-3
+
+Maintainer : mordae@anilinux.org
+Stability : unstable
+Portability : non-portable (ghc)
+
+CSRF mitigation utilities.
+-}
+
+module Hikaru.CSRF
+ ( MonadCsrf(..)
+ , generateToken
+ , isTokenValid
+ )
+where
+ import BasePrelude
+
+ import Control.Monad.Trans
+ import Crypto.Hash
+ import Crypto.MAC.HMAC
+ import Data.ByteString (ByteString)
+ import Data.String.Conversions
+ import Data.Text (Text, splitOn)
+ import Data.Time.Clock.POSIX (getPOSIXTime)
+
+
+ class (MonadIO m) => MonadCsrf m where
+ csrfTokenValidity :: m Int64
+ csrfTokenSecret :: m Text
+
+ default csrfTokenValidity
+ :: (MonadTrans t, MonadCsrf n, m ~ t n) => m Int64
+ csrfTokenValidity = lift csrfTokenValidity
+
+ default csrfTokenSecret
+ :: (MonadTrans t, MonadCsrf n, m ~ t n) => m Text
+ csrfTokenSecret = lift csrfTokenSecret
+
+
+ -- |
+ -- TODO
+ --
+ generateToken :: (MonadCsrf m) => m Text
+ generateToken = do
+ now <- getTimestamp
+ secret <- csrfTokenSecret
+
+ let signature = sign now secret
+ in return $ mconcat [ cs (show now), ":", signature ]
+
+
+ -- |
+ -- TODO
+ --
+ isTokenValid :: (MonadCsrf m) => Text -> m Bool
+ isTokenValid token = do
+ case splitOn ":" token of
+ [time, signature] -> do
+ case readMaybe (cs time) of
+ Just (timestamp :: Int64) -> do
+ now <- getTimestamp
+ valid <- csrfTokenValidity
+ secret <- csrfTokenSecret
+
+ if timestamp + valid >= now
+ then return (sign timestamp secret == signature)
+ else return False
+
+ Nothing -> return False
+
+ _else -> return False
+
+
+ -- Internals --------------------------------------------------------------
+
+
+ getTimestamp :: (MonadIO m) => m Int64
+ getTimestamp = round <$> liftIO getPOSIXTime
+
+
+ sign :: Int64 -> Text -> Text
+ sign timestamp secret = cs $ show $ hmacGetDigest digest
+ where
+ digest = hmac timeBytes secretBytes :: HMAC SHA256
+ secretBytes = cs secret :: ByteString
+ timeBytes = cs time :: ByteString
+ time = show timestamp
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/lib/Hikaru/Form.hs b/lib/Hikaru/Form.hs
index 2a96fc755803ca4bad4a99363e58519638216290..6d40f49064a98ef1509bd01976408bf27a46a0e9 100644
--- a/lib/Hikaru/Form.hs
+++ b/lib/Hikaru/Form.hs
@@ -11,17 +11,19 @@ This module provides applicative form handling.
-}
module Hikaru.Form
- ( View(..)
+ ( MonadCsrf(..)
+ , View(..)
, FormNote(..)
, Form
, FieldT
, newForm
, getForm
, postForm
- , inputField
- , inputField'
, hiddenField
, hiddenField'
+ , csrfTokenField
+ , inputField
+ , inputField'
, textArea
, textArea'
, selectField
@@ -47,6 +49,7 @@ where
import Control.Monad.State
import Data.Text (Text, strip)
import Hikaru.Action
+ import Hikaru.CSRF
import Hikaru.Localize
import Hikaru.Types
import Lucid
@@ -132,7 +135,7 @@ where
= FormT
{ unFormT :: ReaderT (Env l) (StateT (View l) m) a
}
- deriving (Monad, Applicative, Functor)
+ deriving (MonadIO, Monad, Applicative, Functor)
deriving instance (Monad m) => MonadReader (Env l) (FormT l m)
deriving instance (Monad m) => MonadState (View l) (FormT l m)
@@ -140,6 +143,8 @@ where
instance MonadTrans (FormT l) where
lift = FormT . lift . lift
+ instance (MonadCsrf m) => MonadCsrf (FormT l m)
+
newtype Form l m a
= Form
@@ -159,9 +164,6 @@ where
r <- unFormR
return $ l <*> r
- instance MonadTrans (Form l) where
- lift = Form . fmap Just . lift
-
data Env l
= Env
@@ -176,11 +178,13 @@ where
= FieldT
{ unFieldT :: ReaderT Bool (StateT (View l, Maybe a) m) b
}
- deriving (Monad, Applicative, Functor)
+ deriving (MonadIO, Monad, Applicative, Functor)
instance MonadTrans (FieldT l a) where
lift = FieldT . lift . lift
+ instance (MonadCsrf m) => MonadCsrf (FieldT l a m)
+
-- |
-- Build a fresh form without using any request data.
@@ -239,6 +243,46 @@ where
else return (view', value)
+ -- |
+ -- TODO
+ --
+{-
+ csrfTokenField :: (MonadCsrf m) => l -> Form l m Text
+ csrfTokenField msg = Form do
+ token <- generateToken
+
+ unForm $ hiddenField "_token" (Just token) do
+ whenChecking do
+ value <- fromMaybe "" <$> fieldValue
+ valid <- isTokenValid value
+
+ if valid
+ then return ()
+ else addNote $ NoteError msg
+-}
+
+
+ csrfTokenField :: (MonadCsrf m) => l -> Form l m Text
+ csrfTokenField msg = Form do
+ Env{envCheck} <- ask
+
+ name' <- makeName "csrftoken"
+ value <- fromMaybe "" <$> formParamMaybe name'
+ valid <- isTokenValid value
+ token <- generateToken
+
+ let view = HiddenField { viewName = name'
+ , viewValue = Just token
+ , viewNotes = if envCheck && not valid
+ then [NoteError msg]
+ else []
+ , viewAttrs = []
+ }
+
+ modify (<> view)
+ return $ Just token
+
+
-- |
-- TODO
--
diff --git a/package.yaml b/package.yaml
index fc6c75a1bebcbdb768112b23ae42d48cae0b381c..6811789b2c244187743ac0cbfd8810884881a98a 100644
--- a/package.yaml
+++ b/package.yaml
@@ -24,8 +24,10 @@ extra-source-files: README.md
ghc-options: -Wall -Wcompat
default-extensions:
- BlockArguments
+ - DefaultSignatures
- FlexibleInstances
- GeneralizedNewtypeDeriving
+ - GADTs
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
@@ -45,6 +47,7 @@ dependencies:
- case-insensitive >= 1.2 && <1.3
- containers >= 0.6 && <0.7
- cookie >= 0.4 && <0.5
+ - cryptonite >= 0.25 && <0.26
- http-types >= 0.12 && <0.13
- lucid >= 2.9 && <2.10
- mtl >= 2.2 && <2.3
@@ -52,6 +55,7 @@ dependencies:
- string-conversions >= 0.4 && <0.5
- text >= 1.2 && <1.3
- text-icu >= 0.7 && <0.8
+ - time >= 1.8 && <1.9
- wai >= 3.2 && <3.3
- wai-extra >= 3.0 && <3.1
@@ -62,6 +66,7 @@ library:
exposed-modules:
- Hikaru
- Hikaru.Action
+ - Hikaru.CSRF
- Hikaru.Dispatch
- Hikaru.Form
- Hikaru.Link