Views.hs

module Example.Views where

import Example.Types

import TsWeb.Action (getExtra, getPath, showPath)
import TsWeb.Db (QueryResult(..), TxOpt(..), execute, queryList, queryMaybe)
import TsWeb.Types (TsActionCtxT)
import TsWeb.Types.Db (ReadOnlyPool, ReadWritePool)

import qualified Clay as Clay
import qualified Data.Text as Text
import qualified Database.Beam as Beam
import qualified Web.Spock as Spock

import Clay (Css, (?), (|>), px)
import Data.HVect (ListContains)
import Data.Monoid ((<>))
import Data.Text (Text)
import Database.Beam ((==.), all_, default_, guard_, just_, nothing_, pk, val_)
import SuperRecord (Has)
import Web.Routing.Combinators (PathState(Open))
import Web.Spock (Path, text)

adminindex ::
     (ListContains n Admin xs, Has "users" lts (Path '[] 'Open))
  => TsActionCtxT lts xs SessionData a
adminindex = showPath #users >>= \u -> text $ "Hello admin!\n" <> u <> "\n"

userindex ::
     ( ListContains n User xs
     , Has "users" lts (Path '[] 'Open)
     , Has "user" lts (Path '[ Text] 'Open)
     )
  => TsActionCtxT lts xs SessionData a
userindex = do
  (u :: User) <- getExtra
  p0 <- showPath #users
  p1 <- ($ _userLogin u) <$> showPath #user
  text $ "Hello " <> _userLogin u <> "!\n" <> p0 <> "\n" <> p1 <> "\n"

index ::
     (Has "css" lts (Path '[] 'Open), Has "users" lts (Path '[] 'Open))
  => TsActionCtxT lts xs SessionData a
index = do
  p <- getPath #users
  c <- getPath #css
  text $ Spock.renderRoute p <> "\n" <> Spock.renderRoute c <> "\n"

users :: ListContains n ReadOnlyPool xs => TsActionCtxT lts xs SessionData a
users =
  queryList (Beam.select $ all_ (_dbUser db)) >>= \case
    QSimply lst ->
      text $
      "Users: " <> Text.intercalate ", " [_userLogin u | u <- lst] <> "\n"
    QError err -> text $ "Error: " <> Text.pack (show err)

viewuser ::
     ListContains n ReadOnlyPool xs => Text -> TsActionCtxT lts xs SessionData a
viewuser user =
  queryMaybe (Beam.select q) >>= \case
    QError err -> text $ "Error: " <> Text.pack (show err)
    QSimply Nothing -> text $ "User " <> user <> " not found\n"
    QSimply (Just u) -> text $ (Text.pack $ show u) <> "\n"
  where
    q = do
      u <- all_ $ _dbUser db
      guard_ $ _userLogin u ==. val_ user
      pure u

makeuser ::
     ListContains n ReadWritePool xs
  => Text
  -> TsActionCtxT lts xs SessionData a
makeuser user = do
  res <-
    execute NoTx $
    Beam.runInsert $
    Beam.insert (_dbUser db) $
    Beam.insertExpressions [User default_ (val_ user)]
  text $ (Text.pack $ show res) <> "\n"

login ::
     ListContains n ReadOnlyPool xs => Text -> TsActionCtxT lts xs SessionData a
login user =
  queryMaybe (Beam.select q) >>= \case
    QError err -> text $ "Error: " <> Text.pack (show err)
    QSimply Nothing -> text $ "User " <> user <> " not found\n"
    QSimply (Just u) -> do
      sess <- Spock.readSession
      Spock.writeSession $ sess {_sdUser = just_ $ pk u}
      text $ (Text.pack $ show u) <> "\n"
  where
    q = do
      u <- all_ $ _dbUser db
      guard_ $ _userLogin u ==. val_ user
      pure u

loginstat :: ListContains n ReadOnlyPool xs => TsActionCtxT lts xs SessionData a
loginstat = do
  sess <- Spock.readSession
  case _sdUser sess of
    (UserId Nothing) -> text "Not logged in\n"
    (UserId (Just uid)) ->
      queryMaybe (Beam.select $ q uid) >>= \case
        QSimply Nothing -> text "Logged in as a non-existent user!?\n"
        QSimply (Just u) -> text $ "Logged in as " <> _userLogin u <> "\n"
        QError err -> text $ "Error: " <> Text.pack (show err) <> "\n"
  where
    q uid = do
      u <- all_ $ _dbUser db
      guard_ $ _userId u ==. val_ uid
      pure u

logout :: TsActionCtxT lts xs SessionData a
logout = do
  sess <- Spock.readSession
  Spock.writeSession $ sess {_sdUser = nothing_}
  text "Logged Out\n"

style :: Css
style = do
  Clay.header |> Clay.nav ? do
    Clay.background Clay.white
    Clay.color "#04a"
    Clay.fontSize (px 24)
    Clay.padding 20 0 20 (px 0)
    Clay.textTransform Clay.uppercase
    Clay.position Clay.absolute
    Clay.left (px 0)
    Clay.right (px 0)
    Clay.bottom (px (-72))
  ".foo" ?
    Clay.background Clay.grey