Implement CSRF protection form field

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

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

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

lib/Hikaru/CSRF.hs

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

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

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