module Yesod.OldCrud.Simple where

import Prelude
import Data.Monoid
import Lens.Micro
import Lens.Micro.TH

import Yesod.Core
import Yesod.Form
import Yesod.Persist
import Database.Persist.Sql
import Data.Text (Text)
import Control.Monad
import Data.Proxy

import Yesod.OldCrud

data SimpleCrud master p c = SimpleCrud
  { _scAdd        :: WidgetT master IO () -> HandlerT (Crud master p c) (HandlerT master IO) Html
  , _scIndex      :: p -> HandlerT (Crud master p c) (HandlerT master IO) Html
  , _scView       :: Key c -> HandlerT (Crud master p c) (HandlerT master IO) Html
  , _scEdit       :: WidgetT master IO () -> HandlerT (Crud master p c) (HandlerT master IO) Html
  , _scDelete     :: WidgetT master IO () -> HandlerT (Crud master p c) (HandlerT master IO) Html
  , _scDeleteForm :: WidgetT master IO () 
  , _scForm       :: Either p c -> Html -> MForm (HandlerT master IO) (FormResult c, WidgetT master IO ())
  , _scFormWrap   :: Enctype -> Route master -> WidgetT master IO () -> WidgetT master IO ()
  , _scDeleteDb   :: Key c -> YesodDB master p
  , _scAddDb      :: p -> c -> YesodDB master (Key c)
  , _scEditDb     :: Key c -> c -> YesodDB master p
  , _scMessageWrap  :: Html -> Html
  , _scEditParent :: EditParent
  }
makeLenses ''SimpleCrud

emptyParentlessSimpleCrud :: 
     PathPiece (Key a) 
  => Yesod master
  => YesodPersist master
  => PersistEntity a
  => PersistQuery (YesodPersistBackend master)
  => PersistEntityBackend a ~ YesodPersistBackend master
  => SimpleCrud master () a
emptyParentlessSimpleCrud = SimpleCrud 
  (const $ return mempty)  -- add 
  (const $ return mempty)  -- index
  (const $ return mempty)  -- view
  (const $ return mempty)  -- edit
  (const $ return mempty)  -- delete
  mempty (const $ const $ return (FormMissing,mempty)) -- delete form
  (const $ const $ const mempty) -- form wrapper
  delete -- default deletion, assumes no FK constraints
  (const insert) -- default DB add
  replace -- default DB edit
  id -- default message wrap
  EditParentIndex

emptyChildSimpleCrud :: 
     PathPiece (Key a) 
  => Yesod master
  => YesodPersist master
  => PersistEntity a
  => PersistQuery (YesodPersistBackend master)
  => PersistEntityBackend a ~ YesodPersistBackend master
  => (Key a -> YesodDB master p) -> SimpleCrud master p a
emptyChildSimpleCrud getParent = SimpleCrud 
  (const $ return mempty)  -- add 
  (const $ return mempty)  -- index
  (const $ return mempty)  -- view
  (const $ return mempty)  -- edit
  (const $ return mempty)  -- delete
  mempty (const $ const $ return (FormMissing,mempty)) -- delete form
  (const $ const $ const mempty) -- form wrapper
  del -- default deletion, assumes no FK constraints
  (const insert) -- default DB add
  edit -- default DB edit
  id -- default message wrap
  EditParentIndex
  where 
  del k = do
    p <- getParent k
    delete k
    return p
  edit k v = do
    replace k v
    getParent k

emptyHierarchySimpleCrud :: forall a c master.
     SqlBackend ~ YesodPersistBackend master
  => PersistStore (YesodPersistBackend master)
  => YesodPersist master
  => SqlClosure a c
  => SimpleCrud master (Maybe (Key a)) a 
emptyHierarchySimpleCrud = SimpleCrud
  (const $ return mempty)  -- add 
  (const $ return mempty)  -- index
  (const $ return mempty)  -- view
  (const $ return mempty)  -- edit
  (const $ return mempty)  -- delete
  mempty (const $ const $ return (FormMissing,mempty)) -- delete form
  (const $ const $ const mempty) -- form wrapper
  del -- deletion
  closureInsert -- default DB add
  edit -- default DB edit
  id -- default message wrap
  EditParentIndex
  where 
  del k = closureGetParentIdProxied (Proxy :: Proxy c) k
  edit k v = do
    replace k v
    closureGetParentIdProxied (Proxy :: Proxy c) k

applyBasicLayoutsAndForms :: PersistCrudEntity master a
  => SimpleCrud master p a -> SimpleCrud master p a
applyBasicLayoutsAndForms initial = initial
  & scIndex      .~ basicSimpleCrudIndex (toWidget . toHtml . toPathPiece . entityKey)
  & scAdd        .~ lift . defaultLayout
  & scEdit       .~ lift . defaultLayout
  & scDelete     .~ lift . defaultLayout
  & scDeleteForm .~ [whamlet|<button type="submit">Delete|]
  & scFormWrap   .~ formWrap
  where formWrap enctype route inner = [whamlet|$newline never
          <form action="@{route}" enctype="#{enctype}" method="post">
            ^{inner}
        |]

basicSimpleCrudIndex :: (PersistCrudEntity site c)
  => (Entity c -> WidgetT site IO ()) -> p -> HandlerT (Crud site p c) (HandlerT site IO) Html
basicSimpleCrudIndex nameFunc p = do
  tp <- getRouteToParent
  cs <- lift $ runDB $ selectList [] []
  lift $ defaultLayout $ [whamlet|$newline never
    <h1>Index
    <p>
      <a href="@{tp (AddR p)}">Add
    <table.table>
      <thead>
        <tr>
          <th>ID
          <th>Edit
          <th>Delete
      <tbody>
        $forall c <- cs
          <tr>
            <td>^{nameFunc c}
            <td>
              <a href="@{tp (EditR (entityKey c))}">Edit
            <td>
              <a href="@{tp (DeleteR (entityKey c))}">Delete
  |]



basicSimpleCrud :: PersistCrudEntity master a => SimpleCrud master () a
basicSimpleCrud = applyBasicLayoutsAndForms emptyParentlessSimpleCrud

basicChildSimpleCrud :: PersistCrudEntity master a => (Key a -> YesodDB master p) -> SimpleCrud master p a
basicChildSimpleCrud f = applyBasicLayoutsAndForms (emptyChildSimpleCrud f)

basicHierarchySimpleCrud :: (PersistCrudEntity master a, SqlClosure a c)
  => SimpleCrud master (Maybe (Key a)) a
basicHierarchySimpleCrud = applyBasicLayoutsAndForms emptyHierarchySimpleCrud

simpleCrudToCrud :: 
     PersistEntityBackend a ~ YesodPersistBackend master
  => PersistEntity a
  => PersistStore (YesodPersistBackend master)
  => YesodPersist master
  => RenderMessage master FormMessage
  => SimpleCrud master p a -> Crud master p a
simpleCrudToCrud (SimpleCrud add index view edit del delForm form wrap delDb addDb editDb messageWrap editParent) = 
  Crud addH indexH editH delH viewH
  where 
  indexH = index
  viewH = view
  delH theId = do
    tp <- getRouteToParent
    lift $ do
      res <- runInputPostResult $ ireq textField "fake"
      case res of
        FormSuccess _ -> do
          p <- runDB $ delDb theId
          setMessage $ messageWrap "You have deleted the resource."
          redirect (tp $ IndexR p)
        _ -> return ()
    del (wrap UrlEncoded (tp $ DeleteR theId) ([whamlet|<input type="hidden" value="a" name="fake">|] <> delForm))
  addH p = do 
    tp <- getRouteToParent
    (enctype,w) <- lift $ do
      ((res,w),enctype) <- runFormPost (form $ Left p)
      case res of
        FormSuccess a -> do
          void $ runDB $ addDb p a 
          setMessage $ messageWrap "You have created a new resource"
          redirect (tp $ IndexR p)
        _ -> return (enctype,w)
    add (wrap enctype (tp $ AddR p) w)
  editH theId = do
    tp <- getRouteToParent
    (enctype,w) <- lift $ do
      old <- runDB $ get404 theId
      ((res,w),enctype) <- runFormPost (form $ Right old)
      case res of
        FormSuccess new -> do
          p <- runDB $ editDb theId new
          setMessage $ messageWrap "You have updated the resource."
          redirect $ tp $ case editParent of
            EditParentView  -> ViewR theId
            EditParentIndex -> IndexR p
        _ -> return (enctype,w)
    edit (wrap enctype (tp $ EditR theId) w)