@@ -1,6 +1,11 @@
11{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
23{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
37{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE TemplateHaskell #-}
49module Obelisk.Backend
510 ( backend
611 , BackendConfig (..)
@@ -12,14 +17,20 @@ import Prelude hiding ((.))
1217
1318import Control.Category
1419import Control.Monad.IO.Class
20+import Control.Monad.Except
1521import qualified Data.ByteString.Char8 as BSC8
1622import Data.Default (Default (..))
1723import Data.Dependent.Sum
24+import Data.GADT.Show.TH
25+import Data.GADT.Compare.TH
1826import Data.Functor.Identity
1927import Data.Monoid
28+import Data.Some
29+import qualified Data.Some as Some
2030import Data.Text (Text)
2131import qualified Data.Text as T
2232import Data.Text.Encoding
33+import Data.Universe
2334import Obelisk.Asset.Serve.Snap (serveAsset)
2435import Obelisk.Route
2536import Reflex.Dom
@@ -30,16 +41,34 @@ import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog
3041--TODO: Add a link to a large explanation of the idea of using 'def'
3142-- | Configure the operation of the Obelisk backend. For reasonable defaults,
3243-- use 'def'.
33−data BackendConfig = BackendConfig
34− { _backendConfig_head :: StaticWidget () ()
44+data BackendConfig (route :: * -> *) = BackendConfig
45+ { _backendConfig_head :: !(StaticWidget () ())
46+ , _backendConfig_routeEncoder :: !(Encoder (Either Text) (Either Text) (R (ObeliskRoute route)) PageName)
3547 }
3648
37−instance Default BackendConfig where
38− def = BackendConfig (return ())
49+data IndexOnly :: * -> * where
50+ IndexOnly :: IndexOnly ()
51+
52+instance Universe (Some IndexOnly) where
53+ universe = [Some.This IndexOnly]
54+
55+indexOnlyRouteComponentEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (Some IndexOnly) (Maybe Text)
56+indexOnlyRouteComponentEncoder = enum1Encoder $ \case
57+ IndexOnly -> Nothing
58+
59+indexOnlyRouteRestEncoder :: (Applicative check, MonadError Text parse) => IndexOnly a -> Encoder check parse a PageName
60+indexOnlyRouteRestEncoder = \case
61+ IndexOnly -> Encoder $ pure $ endValidEncoder mempty
62+
63+instance route ~ IndexOnly => Default (BackendConfig route) where
64+ def = BackendConfig
65+ { _backendConfig_head = return ()
66+ , _backendConfig_routeEncoder = obeliskRouteEncoder indexOnlyRouteComponentEncoder indexOnlyRouteRestEncoder
67+ }
3968
4069-- | Start an Obelisk backend
41−backend :: ShowTag appRoute Identity => Encoder (Either Text) (Either Text) (R (ObeliskRoute appRoute)) PageName -> BackendConfig -> IO ()
42−backend routeEncoder cfg = do
70+backend :: ShowTag route Identity => BackendConfig route -> IO ()
71+backend cfg = do
4372 -- Make output more legible by decreasing the likelihood of output from
4473 -- multiple threads being interleaved
4574 hSetBuffering stdout LineBuffering
@@ -52,7 +81,7 @@ backend routeEncoder cfg = do
5281 { accessLog = Just $ ConfigIoLog BSC8.putStrLn
5382 , errorLog = Just $ ConfigIoLog BSC8.putStrLn
5483 }
55− let Right routeEncoderValid = checkEncoder routeEncoder --TODO: Report error better
84+ let Right routeEncoderValid = checkEncoder $ _backendConfig_routeEncoder cfg --TODO: Report error better
5685 -- Start the web server
5786 httpServe httpConf $ do
5887 p <- getsRequest rqPathInfo
@@ -79,3 +108,11 @@ blankLoader headHtml = el "html" $ do
79108 el "body" $ do
80109 --TODO: Hash the all.js path
81110 elAttr "script" ("language" =: "javascript" <> "src" =: "ghcjs/all.js" <> "defer" =: "defer") blank
111+
112+deriveGShow ''IndexOnly
113+deriveGEq ''IndexOnly
114+deriveGCompare ''IndexOnly
115+
116+instance ShowTag IndexOnly Identity where
117+ showTaggedPrec = \case
118+ IndexOnly -> showsPrec