{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Helpers.Crud
    ( Item (..)
    , Crud (..)
    , CrudRoute (..)
    , defaultCrud
    ) where

import Yesod.Yesod
import Yesod.Widget
import Yesod.Dispatch
import Yesod.Content
import Yesod.Handler
import Text.Hamlet
import Yesod.Form
import Language.Haskell.TH.Syntax

-- | An entity which can be displayed by the Crud subsite.
class Item a where
    -- | The title of an entity, to be displayed in the list of all entities.
    itemTitle :: a -> String

-- | Defines all of the CRUD operations (Create, Read, Update, Delete)
-- necessary to implement this subsite. When using the "Yesod.Form" module and
-- 'ToForm' typeclass, you can probably just use 'defaultCrud'.
data Crud master item = Crud
    { crudSelect :: GHandler (Crud master item) master [(Key item, item)]
    , crudReplace :: Key item -> item -> GHandler (Crud master item) master ()
    , crudInsert :: item -> GHandler (Crud master item) master (Key item)
    , crudGet :: Key item -> GHandler (Crud master item) master (Maybe item)
    , crudDelete :: Key item -> GHandler (Crud master item) master ()
    }

mkYesodSub "Crud master item"
    [ ClassP ''Yesod [VarT $ mkName "master"]
    , ClassP ''Item [VarT $ mkName "item"]
    , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")]
    , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"]
    ] [$parseRoutes|
/               CrudListR        GET
/add            CrudAddR         GET POST
/edit/#String   CrudEditR        GET POST
/delete/#String CrudDeleteR      GET POST
|]

getCrudListR :: (Yesod master, Item item, SinglePiece (Key item))
             => GHandler (Crud master item) master RepHtml
getCrudListR = do
    items <- getYesodSub >>= crudSelect
    toMaster <- getRouteToMaster
    defaultLayout $ do
        setTitle "Items"
        addBody [$hamlet|
%h1 Items
%ul
    $forall items item
        %li
            %a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@
                $itemTitle.snd.item$
%p
    %a!href=@toMaster.CrudAddR@ Add new item
|]

getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
                ToForm item master)
            => GHandler (Crud master item) master RepHtml
getCrudAddR = crudHelper
                "Add new"
                (Nothing :: Maybe (Key item, item))
                False

postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item),
                 ToForm item master)
             => GHandler (Crud master item) master RepHtml
postCrudAddR = crudHelper
                "Add new"
                (Nothing :: Maybe (Key item, item))
                True

getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
                 ToForm item master)
             => String -> GHandler (Crud master item) master RepHtml
getCrudEditR s = do
    itemId <- maybe notFound return $ itemReadId s
    crud <- getYesodSub
    item <- crudGet crud itemId >>= maybe notFound return
    crudHelper
        "Edit item"
        (Just (itemId, item))
        False

postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item),
                  ToForm item master)
              => String -> GHandler (Crud master item) master RepHtml
postCrudEditR s = do
    itemId <- maybe notFound return $ itemReadId s
    crud <- getYesodSub
    item <- crudGet crud itemId >>= maybe notFound return
    crudHelper
        "Edit item"
        (Just (itemId, item))
        True

getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))
               => String -> GHandler (Crud master item) master RepHtml
getCrudDeleteR s = do
    itemId <- maybe notFound return $ itemReadId s
    crud <- getYesodSub
    item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists
    toMaster <- getRouteToMaster
    defaultLayout $ do
        setTitle "Confirm delete"
        addBody [$hamlet|
%form!method=post!action=@toMaster.CrudDeleteR.s@
    %h1 Really delete?
    %p Do you really want to delete $itemTitle.item$?
    %p
        %input!type=submit!value=Yes
        \ $
        %a!href=@toMaster.CrudListR@ No
|]

postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item))
                => String -> GHandler (Crud master item) master RepHtml
postCrudDeleteR s = do
    itemId <- maybe notFound return $ itemReadId s
    crud <- getYesodSub
    toMaster <- getRouteToMaster
    crudDelete crud itemId
    redirect RedirectTemporary $ toMaster CrudListR

itemReadId :: SinglePiece x => String -> Maybe x
itemReadId = either (const Nothing) Just . fromSinglePiece

crudHelper
    :: (Item a, Yesod master, SinglePiece (Key a), ToForm a master)
    => String -> Maybe (Key a, a) -> Bool
    -> GHandler (Crud master a) master RepHtml
crudHelper title me isPost = do
    crud <- getYesodSub
    (errs, form, enctype) <- runFormPost $ toForm $ fmap snd me
    toMaster <- getRouteToMaster
    case (isPost, errs) of
        (True, FormSuccess a) -> do
            eid <- case me of
                    Just (eid, _) -> do
                        crudReplace crud eid a
                        return eid
                    Nothing -> crudInsert crud a
            redirect RedirectTemporary $ toMaster $ CrudEditR
                                       $ toSinglePiece eid
        _ -> return ()
    defaultLayout $ do
        wrapWidget form (wrapForm toMaster enctype)
        setTitle $ string title
  where
    wrapForm toMaster enctype form = [$hamlet|
%p
    %a!href=@toMaster.CrudListR@ Return to list
%h1 $title$
%form!method=post!enctype=$enctype$
    %table
        ^form^
        %tr
            %td!colspan=2
                %input!type=submit
                $maybe me e
                    \ $
                    %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete
|]

-- | A default 'Crud' value which relies about persistent and "Yesod.Form".
defaultCrud
    :: (PersistEntity i, PersistBackend (YesodDB a (GHandler (Crud a i) a)),
        YesodPersist a)
    => a -> Crud a i
defaultCrud = const Crud
    { crudSelect = runDB $ selectList [] [] 0 0
    , crudReplace = \a -> runDB . replace a
    , crudInsert = runDB . insert
    , crudGet = runDB . get
    , crudDelete = runDB . delete
    }