Merge pull request #7 from cdepillabout/template-haskell-ede

Template haskell ede.
Closes #6.

.hindent.yaml

@@ -0,0 +1,4 @@
+# We use 4 space indents.
+indent-size: 4
+line-length: 80
+force-trailing-newline: false

kucipong.cabal

@@ -46,6 +46,7 @@ library
                      , Kucipong.Monad.SendEmail.Trans
                      , Kucipong.Orphans
                      , Kucipong.Prelude
+                     , Kucipong.RenderTemplate
                      , Kucipong.Session
                      , Kucipong.Spock
                      , Kucipong.Util
@@ -54,6 +55,7 @@ library
                      , base64-bytestring
                      , classy-prelude
                      , clientsession
+                     , ede
                      , emailaddress
                      , envelope
                      , hailgun
@@ -79,6 +81,8 @@ library
                      , resource-pool
                      , shakespeare
                      , Spock
+                     , template-haskell
+                     , th-lift-instances
                      , time
                      , transformers
                      , transformers-base
@@ -87,7 +91,8 @@ library
                      , warp
   default-language:    Haskell2010
   ghc-options:         -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction
-  default-extensions:  ConstraintKinds
+  default-extensions:  BangPatterns
+                     , ConstraintKinds
                      , DataKinds
                      , DefaultSignatures
                      , DeriveDataTypeable
@@ -121,7 +126,8 @@ executable kucipong
   build-depends:       base
                      , kucipong
   default-language:    Haskell2010
-  default-extensions:  ConstraintKinds
+  default-extensions:  BangPatterns
+                     , ConstraintKinds
                      , DataKinds
                      , DefaultSignatures
                      , DeriveDataTypeable
@@ -159,7 +165,8 @@ executable kucipong-add-admin
                      , optparse-applicative
                      , persistent
   default-language:    Haskell2010
-  default-extensions:  ConstraintKinds
+  default-extensions:  BangPatterns
+                     , ConstraintKinds
                      , DataKinds
                      , DefaultSignatures
                      , DeriveDataTypeable

src/Kucipong/Handler/Admin.hs

@@ -1,13 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
 
 module Kucipong.Handler.Admin where
 
 import Kucipong.Prelude
 
 import Control.Lens ( (^.) )
 import Control.Monad.Time ( MonadTime(..) )
+import Data.Aeson ( (.=) )
 import Data.HVect ( HVect(..) )
 import Database.Persist ( Entity(..) )
 import Network.HTTP.Types ( forbidden403 )
+import Text.EDE ( eitherParse, eitherRender, fromPairs )
 import Web.Spock
     ( ActionCtxT, Path, SpockCtxT, (<//>), get, getContext, html, prehook, root
     , redirect, renderRoute, runSpock, setStatus, spockT, text, var )
@@ -18,10 +21,11 @@ import Kucipong.Db
 import Kucipong.LoginToken ( LoginToken )
 import Kucipong.Monad
     ( MonadKucipongCookie, MonadKucipongDb(..), MonadKucipongSendEmail )
+import Kucipong.RenderTemplate ( renderTemplateFromEnv )
 import Kucipong.Spock
     ( ContainsAdminSession, getAdminCookie, getAdminEmail, setAdminCookie )
 import Kucipong.Session ( Admin, Session(..) )
-import Kucipong.Util ( fromMaybeM )
+import Kucipong.Util ( fromEitherM, fromMaybeM )
 
 -- | Login an admin.  Take the admin's 'LoginToken', and send them a session
 -- cookie.
@@ -61,12 +65,13 @@ storeCreate
     :: forall xs n m
      . ( ContainsAdminSession n xs
        , MonadIO m
+       , MonadLogger m
        )
     => ActionCtxT (HVect xs) m ()
 storeCreate = do
     (AdminSession email) <- getAdminEmail
-    -- TODO: Actually return the correct html from here.
-    html $ "admin email: " <> tshow email
+    $(renderTemplateFromEnv "adminUser_admin_store_create.html") $ fromPairs
+        [ "adminEmail" .= email ]
 
 adminAuthHook
     :: ( MonadIO m
@@ -89,6 +94,7 @@ adminComponent
        , MonadKucipongCookie m
        , MonadKucipongDb m
        , MonadKucipongSendEmail m
+       , MonadLogger m
        , MonadTime m
        )
     => SpockCtxT (HVect xs) m ()

src/Kucipong/Monad/OtherInstances.hs

@@ -1,14 +1,3 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Kucipong.Monad.OtherInstances where
-
-import Kucipong.Prelude
-
-import Control.Monad.Random ( MonadRandom(..) )
-
-instance MonadRandom m => MonadRandom (LoggingT m) where
-    getRandom = lift getRandom
-    getRandomR = lift . getRandomR
-    getRandoms = lift getRandoms
-    getRandomRs = lift . getRandomRs
-

src/Kucipong/Orphans.hs

@@ -10,3 +10,22 @@ other libraries but that we use here.
 -}
 
 module Kucipong.Orphans where
+
+import ClassyPrelude
+
+import Control.Monad.Logger ( LoggingT, MonadLogger )
+import Control.Monad.Random ( MonadRandom(..) )
+import Language.Haskell.TH ( Q, runIO )
+import Web.Spock ( ActionCtxT )
+
+instance MonadRandom m => MonadRandom (LoggingT m) where
+    getRandom = lift getRandom
+    getRandomR = lift . getRandomR
+    getRandoms = lift getRandoms
+    getRandomRs = lift . getRandomRs
+
+instance MonadLogger m => MonadLogger (ActionCtxT ctx m)
+
+instance MonadIO Q where
+    liftIO :: IO a -> Q a
+    liftIO = runIO

src/Kucipong/Prelude.hs

@@ -5,7 +5,7 @@ import ClassyPrelude as X
 
 import Control.Monad.Base as X ( MonadBase(..) )
 import Control.Monad.Except as X ( ExceptT(..), MonadError(..), runExceptT )
-import Control.Monad.Logger as X ( LoggingT, MonadLogger )
+import Control.Monad.Logger as X ( LoggingT, MonadLogger, logDebug )
 import Control.Monad.Reader as X ( reader )
 import Control.Monad.Trans.Control as X ( MonadBaseControl )
 import Control.Monad.Trans.Identity as X ( IdentityT(..), runIdentityT )
@@ -14,4 +14,7 @@ import Data.Proxy as X ( Proxy(Proxy) )
 import Data.Word as X ( Word16 )
 import "emailaddress" Text.Email.Validate as X ( EmailAddress )
 
+-- Orphan instances
+
 import Kucipong.Orphans as X ()
+import Instances.TH.Lift as X ()

src/Kucipong/RenderTemplate.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Kucipong.RenderTemplate where
+
+import Kucipong.Prelude hiding ( try )
+
+import Control.Exception ( try )
+import Language.Haskell.TH
+    ( Exp, Q, appE, litE, lookupValueName, mkName, stringL, varE )
+import Language.Haskell.TH.Syntax ( addDependentFile )
+import Network.HTTP.Types ( internalServerError500 )
+import Text.EDE ( Template, eitherParse, eitherRender, fromPairs )
+import Web.Spock ( html, setStatus )
+
+import Kucipong.Util ( fromEitherM )
+
+templateDirectory :: FilePath
+templateDirectory = "frontend" </> "dist"
+
+unsafeFromRight :: Show e => Either e a -> a
+unsafeFromRight (Right a) = a
+unsafeFromRight (Left err) = error $
+    "Called unsafeFromRight, but we got a left with this value: " <> show err
+
+renderTemplateFromEnv :: String -> Q Exp
+renderTemplateFromEnv filename = do
+    addDependentFile fullFilePath
+    eitherRawTemplate <- liftIO . try $ readFile fullFilePath
+    rawTemplate <- fromEitherM handleTemplateFileRead eitherRawTemplate
+    let eitherParsedTemplate = eitherParse rawTemplate
+    -- Check to make sure the template can be parsed correctly.  Return an
+    -- error during compile time to the user if it cannot.
+    void $ fromEitherM handleIncorrectTemplate eitherParsedTemplate
+    templateExp <- [e| unsafeFromRight $ eitherParse rawTemplate |]
+    eitherRenderLambdaExp <- [e| eitherRender $(pure templateExp) |]
+    [e| \environmentObject -> case $(pure eitherRenderLambdaExp) environmentObject of
+            Left err -> do
+                setStatus internalServerError500
+                html $ "<h3>Error with rendering template:</h3>" <> pack err
+            Right bytestring -> html $ toStrict bytestring |]
+  where
+    -- This is the full path of the template file.
+    fullFilePath :: FilePath
+    fullFilePath = templateDirectory </> filename
+
+    handleTemplateFileRead :: SomeException -> Q a
+    handleTemplateFileRead exception = fail $
+        "exception occured when trying to read the template file \"" <>
+        fullFilePath <>
+        ":\n" <>
+        show exception
+
+    handleIncorrectTemplate :: String -> Q a
+    handleIncorrectTemplate errorMsg = fail $
+        "exception occured when trying to parse the template file \"" <>
+        fullFilePath <> ":\n" <> errorMsg

test/DocTest.hs

@@ -14,7 +14,8 @@ doDocTest options = doctest $ options <> ghcExtensions
 
 ghcExtensions :: [String]
 ghcExtensions =
-    [ "-XConstraintKinds"
+    [ "-XBangPatterns"
+    , "-XConstraintKinds"
     , "-XDataKinds"
     , "-XDeriveDataTypeable"
     , "-XDeriveFunctor"