{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
module ~sitearg~
    ( ~sitearg~ (..)
    , ~sitearg~Route (..)
    , resources~sitearg~
    , Handler
    , maybeAuth
    , requireAuth
    , module Yesod
    , module Settings
    , module Model
    , StaticRoute (..)
    , AuthRoute (..)
    ) where

import Yesod
import Yesod.Mail
import Yesod.Helpers.Static
import Yesod.Helpers.Auth
import qualified Settings
import System.Directory
import qualified Data.ByteString.Lazy as L
import Yesod.WebRoutes
import Database.Persist.GenericSql
import Settings (hamletFile, cassiusFile, juliusFile)
import Model
import Control.Monad (join)
import Data.Maybe (isJust)

data ~sitearg~ = ~sitearg~
    { getStatic :: Static
    , connPool :: Settings.ConnectionPool
    }

type Handler = GHandler ~sitearg~ ~sitearg~

mkYesodData "~sitearg~" [$parseRoutes|
/static StaticR Static getStatic
/auth   AuthR   Auth   getAuth

/favicon.ico FaviconR GET
/robots.txt RobotsR GET

/ RootR GET
|~~]

instance Yesod ~sitearg~ where
    approot _ = Settings.approot
    defaultLayout widget = do
        mmsg <- getMessage
        pc <- widgetToPageContent $ do
            widget
            addStyle $(Settings.cassiusFile "default-layout")
        hamletToRepHtml $(Settings.hamletFile "default-layout")
    urlRenderOverride a (StaticR s) =
        Just $ uncurry (joinPath a Settings.staticroot) $ format s
      where
        format = formatPathSegments ss
        ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep))
        ss = getSubSite
    urlRenderOverride _ _ = Nothing
    authRoute _ = Just $ AuthR LoginR
    addStaticContent ext' _ content = do
        let fn = base64md5 content ++ '.' : ext'
        let statictmp = Settings.staticdir ++ "/tmp/"
        liftIO $ createDirectoryIfMissing True statictmp
        liftIO $ L.writeFile (statictmp ++ fn) content
        return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], [])

instance YesodPersist ~sitearg~ where
    type YesodDB ~sitearg~ = SqlPersist
    runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db

instance YesodAuth ~sitearg~ where
    type AuthEntity ~sitearg~ = User
    type AuthEmailEntity ~sitearg~ = Email

    defaultDest _ = RootR

    getAuthId creds _extra = runDB $ do
        x <- getBy $ UniqueUser $ credsIdent creds
        case x of
            Just (uid, _) -> return $ Just uid
            Nothing -> do
                fmap Just $ insert $ User (credsIdent creds) Nothing

    openIdEnabled _ = True

    emailSettings _ = Just EmailSettings
        { addUnverified = \email verkey ->
            runDB $ insert $ Email email Nothing (Just verkey)
        , sendVerifyEmail = sendVerifyEmail'
        , getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
        , setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key]
        , verifyAccount = \eid -> runDB $ do
            me <- get eid
            case me of
                Nothing -> return Nothing
                Just e -> do
                    let email = emailEmail e
                    case emailUser e of
                        Just uid -> return $ Just uid
                        Nothing -> do
                            uid <- insert $ User email Nothing
                            update eid [EmailUser $ Just uid]
                            return $ Just uid
        , getPassword = runDB . fmap (join . fmap userPassword) . get
        , setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass]
        , getEmailCreds = \email -> runDB $ do
            me <- getBy $ UniqueEmail email
            case me of
                Nothing -> return Nothing
                Just (eid, e) -> return $ Just EmailCreds
                    { emailCredsId = eid
                    , emailCredsAuthId = emailUser e
                    , emailCredsStatus = isJust $ emailUser e
                    , emailCredsVerkey = emailVerkey e
                    }
        , getEmail = runDB . fmap (fmap emailEmail) . get
        }

sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()
sendVerifyEmail' email _ verurl =
    liftIO $ renderSendMail Mail
            { mailHeaders =
                [ ("From", "noreply")
                , ("To", email)
                , ("Subject", "Verify your email address")
                ]
            , mailPlain = verurl
            , mailParts = return Part
                { partType = "text/html; charset=utf-8"
                , partEncoding = None
                , partDisposition = Inline
                , partContent = renderHamlet id [$hamlet|
%p Please confirm your email address by clicking on the link below.
%p
    %a!href=$verurl$ $verurl$
%p Thank you
|~~]
                }
            }