{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Web.Blog where

import Model.CoreTypes
import Model.ResponseTypes
import Web.Actions.User
import Web.Forms.Login
import Web.Forms.Post
import Web.Forms.Register
import Web.Utils
import Web.Views.Home
import Web.Views.Site

import Control.Monad
import Control.Monad.Logger
import Control.Monad.Trans
import Data.HVect
import Data.Time
import Database.Persist.Sqlite hiding (get)
import Network.Wai.Middleware.Static
import Text.Blaze.Html (Html, toHtml)
import Text.Digestive.Bootstrap (renderForm)
import Web.Spock hiding (SessionId)
import Web.Spock.Config
import Web.Spock.Digestive
import qualified Data.Configurator as C
import qualified Data.Text as T
import qualified Network.HTTP.Types.Status as Http

type SessionVal = Maybe SessionId
type BlogApp ctx = SpockCtxM ctx SqlBackend SessionVal BlogState ()
type BlogAction ctx a = SpockActionCtx ctx SqlBackend SessionVal BlogState a

data BlogState
   = BlogState
   { bs_cfg :: BlogCfg
   }

data BlogCfg
   = BlogCfg
   { bcfg_db   :: T.Text
   , bcfg_port :: Int
   , bcfg_name :: T.Text
   , bcfg_desc :: T.Text
   }

parseConfig :: FilePath -> IO BlogCfg
parseConfig cfgFile =
    do cfg <- C.load [C.Required cfgFile]
       db <- C.require cfg "db"
       port <- C.require cfg "port"
       name <- C.require cfg "blogName"
       desc <- C.require cfg "blogDescription"
       return (BlogCfg db port name desc)

runBlog :: BlogCfg -> IO ()
runBlog bcfg =
    do pool <- runNoLoggingT $ createSqlitePool (bcfg_db bcfg) 5
       runNoLoggingT $ runSqlPool (runMigration migrateCore) pool
       spockCfg <- defaultSpockCfg Nothing (PCPool pool) (BlogState bcfg)
       runSpock (bcfg_port bcfg) $ spock spockCfg blogApp

mkSite :: (SiteView -> Html) -> BlogAction ctx a
mkSite content =
    maybeUser $ \mUser ->
    do blogSt <- getState
       let cfg = bs_cfg blogSt
           sv =
               SiteView
               { sv_blogName = bcfg_name cfg
               , sv_blogDesc = bcfg_desc cfg
               , sv_user = fmap snd mUser
               }
       blaze $ siteView sv (content sv)

mkSite' :: Html -> BlogAction ctx a
mkSite' content = mkSite (const content)

blogApp :: BlogApp ()
blogApp =
    prehook baseHook $
    do middleware (staticPolicy (addBase "static"))
       get "/" $
           do allPosts <- runSQL $ selectList [] [Desc PostDate]
              mkSite (homeView allPosts)
       get "/about" $
           mkSite mempty
       prehook guestOnlyHook $
               do getpost "/register" registerAction
                  getpost "/login" loginAction
       prehook authHook $
               do get "/logout" logoutAction
                  prehook authorHook $
                      getpost "/write" writeAction
                  prehook adminHook $
                      get "/manage" manageAction

loginAction :: (ListContains n IsGuest xs, NotInList (UserId, User) xs ~ 'True) => BlogAction (HVect xs) a
loginAction =
    do f <- runForm "loginForm" loginForm
       let formView mErr view =
               panelWithErrorView "Login" mErr $ renderForm loginFormSpec view
       case f of -- (View, Maybe LoginRequest)
         (view, Nothing) ->
             mkSite' (formView Nothing view)
         (view, Just loginReq) ->
             do loginRes <-
                    runSQL $ loginUser (lr_user loginReq) (lr_password loginReq)
                case loginRes of
                  Just userId ->
                      do sid <- runSQL $ createSession userId
                         writeSession (Just sid)
                         redirect "/"
                  Nothing ->
                      mkSite' (formView (Just "Invalid login credentials!") view)

registerAction :: (ListContains n IsGuest xs, NotInList (UserId, User) xs ~ 'True) => BlogAction (HVect xs) a
registerAction =
    do f <- runForm "registerForm" registerForm
       let formView mErr view =
               panelWithErrorView "Register" mErr $ renderForm registerFormSpec view
       case f of
         (view, Nothing) ->
             mkSite' (formView Nothing view)
         (view, Just registerReq) ->
             if rr_password registerReq /= rr_passwordConfirm registerReq
             then mkSite' (formView (Just "Passwords do not match") view)
             else do registerRes <-
                         runSQL $ registerUser (rr_username registerReq) (rr_email registerReq) (rr_password registerReq)
                     case registerRes of
                       CommonError errMsg ->
                           mkSite' (formView (Just errMsg) view)
                       CommonSuccess _ ->
                           mkSite' (panelWithErrorView "Register - Success!" Nothing "Great! You may now login.")

manageAction :: ListContains n IsAdmin xs => BlogAction (HVect xs) a
manageAction = mkSite mempty

writeAction :: (ListContains n IsAuthor xs, ListContains m (UserId, User) xs) => BlogAction (HVect xs) a
writeAction =
    do now <- liftIO getCurrentTime
       f <- runForm "writePost" (postForm now)
       let formView mErr view =
               panelWithErrorView "Write a Post" mErr $ renderForm postFormSpec view
       case f of
         (view, Nothing) ->
             mkSite' (formView Nothing view)
         (_, Just newPost) ->
             do _ <- runSQL $ insert newPost
                mkSite' (panelWithErrorView "Post - Success!" Nothing "Thanks for the post! You can now see it on the home page")

logoutAction :: ListContains n (UserId, User) xs => BlogAction (HVect xs) a
logoutAction =
    do (userId, _ :: User) <- liftM findFirst getContext
       runSQL $ killSessions userId
       writeSession Nothing
       redirect "/"

baseHook :: BlogAction () (HVect '[])
baseHook = return HNil

authHook :: BlogAction (HVect xs) (HVect ((UserId, User) ': xs))
authHook =
    maybeUser $ \mUser ->
    do oldCtx <- getContext
       case mUser of
         Nothing ->
             noAccessPage "Unknown user. Login first!"
         Just val ->
             return (val :&: oldCtx)

data IsAdmin = IsAdmin

adminHook :: ListContains n (UserId, User) xs => BlogAction (HVect xs) (HVect (IsAdmin ': xs))
adminHook =
    do (_ :: UserId, user) <- liftM findFirst getContext
       oldCtx <- getContext
       if userIsAdmin user then return (IsAdmin :&: oldCtx) else noAccessPage "You don't have enough rights, sorry"

data IsAuthor = IsAuthor

authorHook :: ListContains n (UserId, User) xs => BlogAction (HVect xs) (HVect (IsAuthor ': xs))
authorHook =
    do (_ :: UserId, user) <- liftM findFirst getContext
       oldCtx <- getContext
       if userIsAuthor user then return (IsAuthor :&: oldCtx) else noAccessPage "You don't have enough rights, sorry"

data IsGuest = IsGuest

guestOnlyHook :: BlogAction (HVect xs) (HVect (IsGuest ': xs))
guestOnlyHook =
    maybeUser $ \mUser ->
    do oldCtx <- getContext
       case mUser of
         Nothing -> return (IsGuest :&: oldCtx)
         Just _ -> redirect "/"

noAccessPage :: T.Text -> BlogAction ctx a
noAccessPage msg =
    do setStatus Http.status403
       prefResp <- preferredFormat
       case prefResp of
         PrefJSON ->
             json (CommonError msg)
         _ ->
             mkSite' (panelWithErrorView "No Access" Nothing (toHtml msg))

maybeUser :: (Maybe (UserId, User) -> BlogAction ctx a) -> BlogAction ctx a
maybeUser action =
    do sess <- readSession
       case sess of
         Nothing ->
             action Nothing
         Just sid ->
             do mUser <- runSQL $ loadUser sid
                action mUser
