{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeFamilies, GADTs, GeneralizedNewtypeDeriving, OverloadedStrings, TupleSections #-}

module Web.Informative where

import Control.Applicative
import Control.Arrow
import Control.Monad
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Format
import Database.Persist.Sql
import System.Locale
import Text.Cassius
import Text.CSV
import Text.Hamlet
import qualified Text.Pandoc as P
import Web.Informative.Data
import Yesod
import Yesod.Auth
import Yesod.Form

type WikiHandler a = forall master. (YesodWikiAuth master, YesodPersist master, YesodPersistBackend master ~ SqlPersistT) => HandlerT Informative (HandlerT master IO) a

class (Yesod master, RenderMessage master FormMessage) => YesodWikiAuth master where
  getAuthR :: HandlerT master IO (AuthRoute -> Route master)
  getUserName :: HandlerT master IO T.Text
  isLoggedIn :: HandlerT master IO Bool
  wikiLayout :: WidgetT master IO () -> HandlerT master IO Html

share [mkPersist sqlSettings, mkMigrate "migrateWiki"] [persistLowerCase|
Wikipage
  title T.Text
  segment T.Text
  editor T.Text
  timestamp UTCTime
  UniquePage title segment timestamp
Wikisection
  content T.Text
  format TextFormat
  kind TextKind
Wikirel
  page WikipageId
  section WikisectionId
  index Int
  UniqueRel page section
Wikisugg
  page T.Text
  segment T.Text
  index Int
  caption T.Text
  UniqueSugg page segment
|]

readFmt Markdown = P.readMarkdown
readFmt MediaWiki = P.readMediaWiki
readFmt ReStructuredText = P.readRST
readFmt LaTeX = P.readLaTeX
convFmt Plain = toHtml
convFmt fmt = preEscapedToMarkup . P.writeHtml P.def . readFmt fmt P.def
convSect Table fmt = convTable fmt
convSect Mapping fmt = convTable fmt
convSect _ fmt = Left . convFmt fmt . T.unpack
convTable :: TextFormat -> T.Text -> Either Html [[Html]]
convTable fmt t = case parseCSV (T.unpack "wikipage") (T.unpack t) of
  Left err -> Left $ toHtml $ show err
  Right csv -> Right $ map (map (convFmt fmt)) csv

getArticleIdR :: Int -> WikiHandler Html
getArticleIdR pageid = do
  seg <- liftM getSegment getYesod
  pref <- liftM getPrefix getYesod
  (edits,sects',page,suggs) <- lift $ runDB $ do
    let pid = Key (PersistInt64 $ fromIntegral pageid) :: WikipageId
    wp <- get pid
    (sects,page) <- case wp of
      Nothing -> return ([(-1,Left $ convFmt LaTeX "\\section{404 Not Found} We're sorry, but that article doesn't exist in our database.", Error)],"none")
      Just p -> do
        rels <- selectList [WikirelPage ==. pid] [Asc WikirelIndex]
        sects <- forM rels $ \(Entity (Key (PersistInt64 rid)) r) -> liftM (rid,) $ get $ wikirelSection r
        let s' = map (\(rid,Just  s) -> (rid,convSect (wikisectionKind s) (wikisectionFormat s) (wikisectionContent s), wikisectionKind s)) sects
        return (s', wikipageTitle p)
    hs <- selectList [WikipageTitle ==. page, WikipageSegment ==. seg] [Desc WikipageTimestamp, LimitTo 10]
    let es = map (\(Entity (Key (PersistInt64 pid)) p) -> (pid, wikipageEditor p, wikipageTimestamp p)) hs
    suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
    return (es,sects,page,suggs)
  toParent <- getRouteToParent
  mayEdit <- lift $ isAuthorized (toParent $ ArticleR page) True
  authR <- lift getAuthR
  loggedIn <- lift isLoggedIn
  mmsg <- getMessage
  let sects = zip [1..] sects'
  lift $ wikiLayout $ do
    setTitle $ toHtml page
    toWidget $(hamletFile "informative.htm")
    toWidget $(cassiusFile "informative.css")

getArticleR :: T.Text -> WikiHandler Html
getArticleR page = do
  seg <- liftM getSegment getYesod
  pref <- liftM getPrefix getYesod
  (edits,sects',suggs) <- lift $ runDB $ do
    wp <- selectList [WikipageTitle ==. page, WikipageSegment ==. seg] [Desc WikipageTimestamp, LimitTo 10]
    suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
    case wp of
      [] -> return ([], [(-1,Left $ convFmt LaTeX "\\section{404 Not Found} We're sorry, but that article doesn't exist in our database.", Error)],suggs)
      hs@((Entity pid p):_) -> do
        rels <- selectList [WikirelPage ==. pid] [Asc WikirelIndex]
        sects <- forM rels $ \(Entity (Key (PersistInt64 rid)) r) -> liftM (rid,) $ get $ wikirelSection r
        let s' = map (\(rid,Just  s) -> (rid,convSect (wikisectionKind s) (wikisectionFormat s) (wikisectionContent s), wikisectionKind s)) sects
            es = map (\(Entity (Key (PersistInt64 pid)) p) -> (pid, wikipageEditor p, wikipageTimestamp p)) hs
        return (es, s',suggs)
  toParent <- getRouteToParent
  mayEdit <- lift $ isAuthorized (toParent $ ArticleR page) True
  authR <- lift getAuthR
  loggedIn <- lift isLoggedIn
  mmsg <- getMessage
  let sects = zip [1..] sects'
  lift $ wikiLayout $ do
    setTitle $ toHtml page
    toWidget $(hamletFile "informative.htm")
    toWidget $(cassiusFile "informative.css")

data SectionData = SectionData {
  sdKind :: TextKind,
  sdFormat :: TextFormat,
  sdContent :: Textarea
  }

editSectionForm :: RenderMessage master FormMessage => Maybe SectionData -> Html -> MForm (HandlerT master IO) (FormResult SectionData, WidgetT master IO ())
editSectionForm mdata = renderDivs $ SectionData
                        <$> areq (selectFieldList kinds) "Kind:" (sdKind <$> mdata)
                        <*> areq (selectFieldList formats) "Format:" (sdFormat <$> mdata)
                        <*> areq textareaField "Content:" (sdContent <$> mdata)
  where formats = map (T.pack . show &&& id) [minBound..maxBound]
        kinds = map (T.pack . show &&& id) [minBound..maxBound]

getEditR :: T.Text -> Int -> WikiHandler Html
getEditR page rid = do
  seg <- liftM getSegment getYesod
  pref <- liftM getPrefix getYesod
  (msect, mprec, kind, fmt, suggs) <- lift $ runDB $ do
    suggs <- selectList [WikisuggSegment ==. seg] [Asc WikisuggIndex]
    rel <- get (Key (PersistInt64 $ fromIntegral rid) :: WikirelId)
    case rel of
      Nothing -> return (Nothing, Nothing, Error, Plain, suggs)
      Just rel -> do
        msect <- get $ wikirelSection rel
        case msect of
          Nothing -> return (Nothing, Nothing, Error, Plain, suggs)
          Just sect ->
            return (Just $ convSect (wikisectionKind sect) (wikisectionFormat sect) (wikisectionContent sect), Just $ wikisectionContent sect, wikisectionKind sect, wikisectionFormat sect, suggs)
  toParent <- getRouteToParent
  authR <- lift getAuthR
  loggedIn <- lift isLoggedIn
  mmsg <- getMessage
  (formw, enctype) <- lift $ generateFormPost $ editSectionForm $ liftM (\t -> SectionData kind fmt $ Textarea t) mprec
  form <- lift $ widgetToPageContent formw
  lift $ wikiLayout $ do
    setTitle $ toHtml page
    toWidget $ pageHead form
    toWidget $(hamletFile "informative-edit.htm")
    toWidget $(cassiusFileReload "informative.css")

instance (YesodWikiAuth master, YesodPersist master, YesodPersistBackend master ~ SqlPersistT) => YesodSubDispatch Informative (HandlerT master IO) where
  yesodSubDispatch = $(mkYesodSubDispatch resourcesInformative)