module Yesod.OldCrud where

import Prelude
import Control.Applicative
import Data.Maybe

import Lens.Micro.TH

import Yesod.Core
import Database.Persist (Key)
import Network.Wai (pathInfo, requestMethod)
import Yesod.Persist hiding (Key)
import Database.Persist.Sql
import Data.Foldable (for_)
import Data.Text (Text)
import Data.Monoid
import qualified Data.List as List
import qualified Database.Esqueleto as E

import Yesod.OldCrud.Internal
import Data.Typeable
import Data.Proxy
import Unsafe.Coerce (unsafeCoerce)

-- In Crud, c is the child type, and p is the type of the identifier
-- for its parent.
data Crud master p c = Crud
  { _ccAdd    :: p -> HandlerT (Crud master p c) (HandlerT master IO) Html
  , _ccIndex  :: p -> HandlerT (Crud master p c) (HandlerT master IO) Html
  , _ccEdit   :: Key c -> HandlerT (Crud master p c) (HandlerT master IO) Html
  , _ccDelete :: Key c -> HandlerT (Crud master p c) (HandlerT master IO) Html
  , _ccView   :: Key c -> HandlerT (Crud master p c) (HandlerT master IO) Html
  }
makeLenses ''Crud

data EditParent = EditParentView | EditParentIndex

breadcrumbsCrud' :: PersistCrudEntity master c
  => EditParent
  -> (Route (Crud master p c) -> Route master) 
  -> Route (Crud master p c) 
  -> Text
  -> (Entity c -> Text)
  -> (Key c -> YesodDB master p)
  -> (p -> YesodDB master (Maybe (Route master))) 
  -> HandlerT master IO (Text, Maybe (Route master))
breadcrumbsCrud' editParent tp route indexName getName getParent getIndexParent = case route of
  AddR p -> return ("Add", Just $ tp $ IndexR p)
  IndexR p -> do
    indexParent <- runDB $ getIndexParent p
    return (indexName, indexParent)
  ViewR cid -> do
    c <- runDB $ get404 cid
    p <- runDB $ getParent cid
    return (getName (Entity cid c), Just $ tp $ IndexR p)
  EditR cid -> case editParent of
    EditParentView  -> return ("Edit", Just $ tp $ ViewR cid)
    EditParentIndex -> do
      c <- runDB $ get404 cid
      p <- runDB $ getParent cid
      return ("Edit - " <> getName (Entity cid c), Just $ tp $ IndexR p)
  DeleteR cid -> return ("Delete", Just $ tp $ ViewR cid)

breadcrumbsCrud2 :: PersistCrudEntity master c
  => (Route (Crud master p c) -> Route master) 
  -> Route (Crud master p c) 
  -> Text
  -> (Entity c -> Text)
  -> (Key c -> YesodDB master p)
  -> (p -> YesodDB master (Maybe (Route master))) 
  -> HandlerT master IO (Text, Maybe (Route master))
breadcrumbsCrud2 = breadcrumbsCrud' EditParentView

breadcrumbsCrud :: 
     PersistCrudEntity master c
  => (Route (Crud master p c) -> Route master) 
  -> Route (Crud master p c) 
  -> Text
  -> (Entity c -> Text)
  -> (Key c -> YesodDB master p)
  -> (p -> YesodDB master (Maybe (Route master))) 
  -> HandlerT master IO (Text, Maybe (Route master))
breadcrumbsCrud = breadcrumbsCrud' EditParentIndex

breadcrumbsCrudHierarchy :: (PersistCrudEntity master a, SqlClosure a c)
  => (Route (Crud master (Maybe (Key a)) a) -> Route master) 
  -> Route (Crud master (Maybe (Key a)) a) 
  -> Text
  -> Maybe (Route master)
  -> (a -> Text)
  -> HandlerT master IO (Text, Maybe (Route master))
breadcrumbsCrudHierarchy tp route indexName parent getName = case route of
  AddR p -> return ("Add", Just $ tp $ IndexR p)
  ViewR cid -> do
    c <- runDB $ get404 cid
    p <- runDB $ closureGetParentId cid
    return ("View - " <> getName c, Just $ tp $ IndexR p)
  EditR cid -> do
    c <- runDB $ get404 cid
    p <- runDB $ closureGetParentId cid
    return ("Edit - " <> getName c, Just $ tp $ IndexR p)
  DeleteR cid -> do
    c <- runDB $ get404 cid
    p <- runDB $ closureGetParentId cid
    return ("Delete - " <> getName c, Just $ tp $ IndexR p)
  IndexR Nothing -> return (indexName, parent)
  IndexR (Just cid) -> do
    c <- runDB $ get404 cid
    p <- runDB $ closureGetParentId cid
    return (getName c, Just . tp . IndexR $ p)

-- By using this, you will trade some type safety
data SomeCrud master = forall p c. (Typeable p, Typeable c) => SomeCrud (Crud master p c)

findCrud :: forall p c master. (Typeable p, Typeable c) => [SomeCrud master] -> Crud master p c
findCrud = fromJust . go 
  where
  go (SomeCrud (crud :: Crud master p1 c1):cs) = 
    if typeRep (Proxy :: Proxy p1) == typeRep (Proxy :: Proxy p)
       && typeRep (Proxy :: Proxy c1) == typeRep (Proxy :: Proxy c)
      then Just (unsafeCoerce crud)
      else go cs
  go [] = Nothing

-- Dispatch for the child crud subsite
instance (Eq (Key c), PathPiece (Key c), Eq p, PathPiece p) => YesodSubDispatch (Crud master p c) (HandlerT master IO) where
  yesodSubDispatch env req = h
    where 
    h = let parsed = parseRoute (pathInfo req, []) 
            helper a = subHelper (fmap toTypedContent a) env parsed req
        in case parsed of
          Just (EditR theId)   -> onlyAllow ["GET","POST"]
            $ helper $ getYesod >>= (\s -> _ccEdit s theId)
          Just (DeleteR theId) -> onlyAllow ["GET","POST"] 
            $ helper $ getYesod >>= (\s -> _ccDelete s theId)
          Just (AddR p) -> onlyAllow ["GET","POST"] 
            $ helper $ getYesod >>= (\s -> _ccAdd s p)
          Just (IndexR p) -> onlyAllow ["GET"] 
            $ helper $ getYesod >>= (\s -> _ccIndex s p)
          Just (ViewR theId) -> onlyAllow ["GET"] 
            $ helper $ getYesod >>= (\s -> _ccView s theId)
          Nothing              -> notFoundApp
    onlyAllow reqTypes waiApp = if isJust (List.find (== requestMethod req) reqTypes) then waiApp else notFoundApp
    notFoundApp = subHelper (fmap toTypedContent notFoundUnit) env Nothing req
    notFoundUnit = fmap (\() -> ()) notFound

instance (PathPiece (Key c), Eq (Key c), PathPiece p, Eq p) => RenderRoute (Crud master p c) where
  data Route (Crud master p c)
    = EditR (Key c)
    | DeleteR (Key c)
    | IndexR p
    | AddR p
    | ViewR (Key c)
  renderRoute r = noParams $ case r of
    EditR theId   -> ["edit",   toPathPiece theId]
    DeleteR theId -> ["delete", toPathPiece theId]
    IndexR p      -> ["index",  toPathPiece p]
    AddR p        -> ["add",    toPathPiece p]
    ViewR theId   -> ["view",   toPathPiece theId]
    where noParams xs = (xs,[])

instance (PathPiece (Key c), Eq (Key c), PathPiece p, Eq p) => ParseRoute (Crud master p c) where
  parseRoute (_, (_:_)) = Nothing
  parseRoute (xs, []) = Nothing
    <|> (runSM xs $ pure EditR <* consumeMatchingText "edit" <*> consumeKey)
    <|> (runSM xs $ pure DeleteR <* consumeMatchingText "delete" <*> consumeKey)
    <|> (runSM xs $ pure IndexR <* consumeMatchingText "index" <*> consumeKey)
    <|> (runSM xs $ pure AddR <* consumeMatchingText "add" <*> consumeKey)
    <|> (runSM xs $ pure ViewR <* consumeMatchingText "view" <*> consumeKey)

deriving instance (Eq (Key c), Eq p) => Eq (Route (Crud master p c))
deriving instance (Show (Key c), Show p) => Show (Route (Crud master p c))
deriving instance (Read (Key c), Read p) => Read (Route (Crud master p c))

type HierarchyCrud master a = Crud master (Maybe (Key a)) a

class (NodeTable c ~ a, ClosureTable a ~ c) => ClosureTablePair a c where
  type NodeTable c
  type ClosureTable a
  closureAncestorCol :: EntityField c (Key a)
  closureDescendantCol :: EntityField c (Key a)
  closureDepthCol :: EntityField c Int
  closureAncestor :: c -> Key a
  closureDescendant :: c -> Key a
  closureDepth :: c -> Int
  closureCreate :: Key a -> Key a -> Int -> c

type PersistCrudEntity master a =
  ( PathPiece (Key a) 
  , Yesod master
  , YesodPersist master
  , PersistEntity a
  , PersistQuery (YesodPersistBackend master)
  , PersistEntityBackend a ~ YesodPersistBackend master
  )

type SqlClosure a c = 
  ( ClosureTablePair a c
  , PersistEntityBackend a ~ SqlBackend
  , PersistEntityBackend (ClosureTable a) ~ SqlBackend
  , PersistEntity a
  , PersistEntity c
  , PersistField (Key a)
  )

closureDepthColAs :: forall a c. ClosureTablePair a c 
  => Key a -> EntityField c Int
closureDepthColAs _ = (closureDepthCol :: EntityField c Int)

closureGetRootNodes :: (MonadIO m, SqlClosure a c) => SqlPersistT m [Entity a]
closureGetRootNodes = E.select $ E.from $ \a -> do
  E.where_ $ E.notExists $ E.from $ \c -> do
    E.where_ $ c E.^. closureDescendantCol E.==. a E.^. persistIdField
         E.&&. c E.^. closureDepthCol E.>. E.val 0
  return a

-- This includes the child itself, the root comes first
closureGetParents :: (MonadIO m, SqlClosure a c) => Key a -> SqlPersistT m [Entity a]
closureGetParents theId = E.select $ E.from $ \(a `E.InnerJoin` c) -> do
  E.on $ a E.^. persistIdField E.==. c E.^. closureAncestorCol
  E.where_ $ c E.^. closureDescendantCol E.==. E.val theId
  E.orderBy [E.desc $ c E.^. closureDepthCol]
  return a

closureGetMaybeImmidiateChildren :: (MonadIO m, SqlClosure a c)
  => Maybe (Key a) -> SqlPersistT m [Entity a]
closureGetMaybeImmidiateChildren Nothing = closureGetRootNodes
closureGetMaybeImmidiateChildren (Just k) = closureGetImmidiateChildren k

closureGetImmidiateChildren :: (MonadIO m, SqlClosure a c) 
   => Key a -> SqlPersistT m [Entity a]
closureGetImmidiateChildren theId = do
  cs <- selectList [closureAncestorCol ==. theId, closureDepthCol ==. 1] []
  selectList [persistIdField <-. map (closureDescendant . entityVal) cs] [Asc persistIdField]

closureGetParentId :: (MonadIO m, SqlClosure a c) 
   => Key a -> SqlPersistT m (Maybe (Key a))
closureGetParentId theId = do
  cs <- selectList [closureDescendantCol ==. theId, closureDepthCol ==. 1] []
  return $ fmap (closureAncestor . entityVal) $ listToMaybe cs

closureGetParentIdProxied :: (MonadIO m, SqlClosure a c) 
   => p c -> Key a -> SqlPersistT m (Maybe (Key a))
closureGetParentIdProxied _ = closureGetParentId

closureInsert :: forall m a c. (MonadIO m, SqlClosure a c) 
  => Maybe (Key a) -> a -> SqlPersistT m (Key a)
closureInsert mparent a = do
  childId <- insert a
  _ <- insert $ closureCreate childId childId 0 
  for_ mparent $ \parentId -> do
    cs <- selectList [closureDescendantCol ==. parentId] []
    insertMany_ $ map (\(Entity _ c) -> 
      closureCreate (closureAncestor c) childId (closureDepth c + 1)) cs 
  return childId

closureRootNodes :: (MonadIO m, SqlClosure a c) => SqlPersistT m [Entity a]
closureRootNodes = error "Write this" -- probably with esqueleto