{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, TypeFamilies, TemplateHaskell, StandaloneDeriving #-}
module State where

import Data.Typeable
import Control.Monad.State
import Control.Monad.Reader

import Database.HDBC.PostgreSQL
import Snap.Snaplet.Hdbc

import Data.Text (Text)
import qualified Data.Text as T

import Data.Set (Set)
import qualified Data.Set as S

import Data.Map (Map, (!))
import qualified Data.Map as M

import Data.Maybe (listToMaybe)


import Text.Digestive.Util (readMaybe)
import Data.List (sortBy)
import Data.List.Split (splitOn)
import Data.Ord (comparing)

import Application

pageSize :: Int
pageSize = 5

data Author = Author { aId :: Text, aName :: Text, aEmail :: Text, aAdmin :: Bool } deriving (Eq, Ord, Show, Typeable)
data Category = Category { cId :: Text, cName :: Text } deriving (Eq, Ord, Show, Typeable)
data Tag = Tag { tId :: Text, tName :: Text } deriving (Eq, Ord, Show, Typeable)
data Date = Date { dYear :: Int, dMonth :: Int, dDay :: Int } deriving (Eq, Typeable)
instance Ord Date where
  (Date y1 m1 d1) <= (Date y2 m2 d2) = (y1 < y2) || ((y1 == y2) && (m1 < m2)) || ((y1 == y2) && (m1 == m2) && (d1 <= d2))
instance Show Date where
  show (Date year month day) = (show month) ++ "." ++ (pad $ show day) ++ "." ++ (show year)
    where pad d = if length d < 2 then '0':d else d
instance Read Date where
  readsPrec _ value = pd $ splitOn (".") value
    where pd (month:day:year:[]) = mkDate (readMaybe year) (readMaybe month) (readMaybe day)
          pd _ = []
          mkDate (Just y) (Just m) (Just d) = [(Date y m d, "")]
          mkDate _ _ _ = []
data AmPm = AM | PM deriving (Eq,Show,Read,Typeable)
data Time = Time {tHour :: Int, tMinute :: Int, tAmPm :: AmPm} deriving (Eq, Typeable)
instance Ord Time where
  (Time _ _ AM) <= (Time _ _ PM) = True
  (Time _ _ PM) <= (Time _ _ AM) = False
  (Time h1 m1 _) <= (Time h2 m2 _) = (h1 < h2) || (h1 == h2 && m1 < m2)
instance Show Time where
  show (Time h m a) = (show h) ++ ":" ++ (pad $ show m) ++ (show a)
      where pad m = if length m < 2 then '0':m else m

instance Read Time where
  readsPrec _ value = pd $ splitOn ":" value
    where pd (hr:minam:[]) = mkTime (readMaybe hr) (readMaybe (reverse $ drop 2 $ reverse minam)) (readMaybe (reverse $ take 2 $ reverse minam))
          pd _ = []
          mkTime (Just hr) (Just min) (Just ampm) = [(Time hr min ampm, "")]
          mkTime _ _ _ = []

data Entry = Entry { eId :: Text, eTitle :: Text, eSynopsis :: Text, eUrl :: Text, eContent :: Text, eCategory :: Category, eAuthor :: Text, eTags :: S.Set Tag, eDate :: Date, eTime :: Time, eSlug :: Text, eDraft :: Bool, eFiles :: M.Map Text (Text,Text,Text), ePage :: Bool } deriving (Eq, Show, Typeable)

toAuthor row = Author (fromSql (row ! "id")) (fromSql (row ! "name")) (fromSql (row ! "email")) (fromSql (row ! "admin"))
fromAuthor (Author id' name email admin) = [toSql name, toSql email, toSql admin, toSql id']

toCategory row = Category (fromSql (row ! "id")) (fromSql (row ! "name"))
fromCategory (Category id' name) = [toSql name, toSql id']

toTag row = Tag (fromSql (row ! "id")) (fromSql (row ! "name"))
fromTag (Tag id' name) = [toSql name, toSql id']

toFile row = (fromSql (row ! "file_name"), (fromSql (row ! "file_ext"), fromSql (row ! "file_path"), fromSql (row ! "id")))
fromFile (name, (ext, path, id')) = [toSql name, toSql ext, toSql path, toSql id']

toEntry (row,tags,files) = Entry 
                         (fromSql (row ! "id")) 
                         (fromSql (row ! "title")) 
                         (fromSql (row ! "synopsis")) 
                         (fromSql (row ! "url")) 
                         (fromSql (row ! "content")) 
                         (Category (fromSql (row ! "cid")) (fromSql (row ! "cname"))) 
                         (fromSql (row ! "author_id"))
                         tags
                         (read $ fromSql (row ! "date"))
                         (read $ fromSql (row ! "time")) 
                         (fromSql (row ! "slug")) 
                         (fromSql (row ! "draft")) 
                         files
                         (fromSql (row ! "page"))
-- note that we do not handle tags and files here - they are simply skipped.
fromEntry (Entry id' title synopsis url content category author tags date time slug draft files page) = 
  [toSql title, toSql synopsis, toSql url, toSql content, toSql (cId category), toSql author, toSql $ show date, toSql $ show time, toSql slug, toSql draft, toSql page, toSql id']

toAccountToken row = ((fromSql (row ! "token"),fromSql (row ! "email")),fromSql (row ! "admin"))

allAuthors :: AppHandler [Author]
allAuthors = do rows <- query "SELECT * FROM authors" []
                return $ map toAuthor rows
  
newAuthor :: Author -> AppHandler ()
newAuthor a = do query' "INSERT INTO authors (name,email,admin) VALUES (?,?,?)" (init $ fromAuthor a)
                 return ()
                 
lookupAuthorByEmail :: Text -> AppHandler (Maybe Author)
lookupAuthorByEmail email = do rows <- query "SELECT * FROM authors WHERE email = ?" [toSql email]
                               return $ fmap toAuthor $ listToMaybe rows

lookupAuthorByName :: Text -> AppHandler (Maybe Author)
lookupAuthorByName name = do rows <- query "SELECT * FROM authors WHERE name = ?" [toSql name]
                             return $ fmap toAuthor $ listToMaybe rows

lookupAuthorById :: Text -> AppHandler (Maybe Author)
lookupAuthorById id' = do rows <- query "SELECT * FROM authors WHERE id = ?" [toSql id']
                          return $ fmap toAuthor $ listToMaybe rows

updateAuthor :: Author -> AppHandler ()
updateAuthor a = do query' "UPDATE authors SET name = ?, email = ?, admin = ? WHERE id = ?" (fromAuthor a)
                    return ()

allCategories :: AppHandler [Category]  
allCategories = do rows <- query "SELECT * FROM categories" []
                   return $ map toCategory rows
  
newCategory :: Category -> AppHandler ()
newCategory c = do query' "INSERT INTO categories (name) VALUES (?)" (init $ fromCategory c)
                   return ()

lookupCategory :: Text -> AppHandler (Maybe Category)
lookupCategory cat = do rows <- query "SELECT * FROM categories WHERE name = ?" [toSql cat]
                        return $ fmap toCategory $ listToMaybe rows

allTags :: AppHandler [Tag]  
allTags = do rows <- query "SELECT * FROM tags" []
             return $ map toTag rows

newTag :: Tag -> AppHandler Text
newTag t = do rows <- query "INSERT INTO tags (name) VALUES (?) RETURNING id" (init $ fromTag t)
              return $ maybe "" (fromSql.(! "id")) (listToMaybe rows)

lookupTag :: Text -> AppHandler (Maybe Tag)
lookupTag tn = do rows <- query "SELECT * FROM tags WHERE name = ?" [toSql tn]
                  return $ fmap toTag $ listToMaybe rows

deleteTag :: Tag -> AppHandler ()
deleteTag t = do query' "DELETE FROM tags WHERE id = ?" [toSql $ tId t]
                 return ()

timeSort = sortBy (\a b -> case compare (eDate b) (eDate a) of
                             EQ -> compare (eTime b) (eTime a)
                             x -> x)

getEntryTags row = fmap (S.fromList.(map toTag)) $ query "SELECT * FROM entry_tags AS E JOIN tags on E.tag_id = id WHERE E.entry_id = ?" [row ! "id"]
getEntryFiles row = fmap (M.fromList.(map toFile)) $ query "SELECT * FROM entry_files WHERE entry_id = ?" [row ! "id"]

allEntries :: AppHandler [Entry]  
allEntries = do rows <- query "SELECT E.id,title,synopsis,url,content,author_id,category_id,slug,draft,page,date,time,C.id as Cid, C.name as Cname FROM entries as E JOIN categories as C on C.id = category_id WHERE page = false" []
                tags <- mapM getEntryTags rows
                files <- mapM getEntryFiles rows
                return $ timeSort $ map toEntry (zip3 rows tags files)
             
-- this is a stupid way of doing it, but will have to do for now.
-- the obvious improvement is to store the date in a way that the database
-- inderstands, and then use limit/offset/order by to accomplish this there.
allEntriesByPage :: Int -> AppHandler [Entry]  
allEntriesByPage p = do es <- allEntries
                        return $ take pageSize $ drop ((p-1)*pageSize) es

allNonAudioEntriesByPage :: Int -> AppHandler [Entry]
allNonAudioEntriesByPage p = do es <- allEntries
                                return $ take pageSize $ drop ((p-1)*pageSize) $ filter (\e -> (not ((cName $ eCategory e) == "Audio"))) es 

allEntriesInCategory :: Category -> AppHandler [Entry]
allEntriesInCategory c = do es <- allEntries
                            return $ filter (\e -> eCategory e == c) es
 
allEntriesWithTag :: Tag -> AppHandler [Entry]
allEntriesWithTag t = do es <- allEntries
                         return $ filter (\e -> S.member t (eTags e)) es

allEntriesByAuthor :: Author -> AppHandler [Entry]
allEntriesByAuthor a = do es <- allEntries
                          return $ filter (\e -> (eAuthor e == aId a) && ((cName $ eCategory e) == "Text")) es 

allPages :: AppHandler [Entry]
allPages = do rows <- query "SELECT E.id,title,synopsis,url,content,author_id,category_id,slug,draft,page,date,time,C.id as Cid, C.name as Cname FROM entries AS E JOIN categories AS C on category_id = C.id WHERE page = true" []
              tags <- mapM getEntryTags rows
              files <- mapM getEntryFiles rows
              return $ map toEntry (zip3 rows tags files)

lookupEntry :: Date -> Text -> AppHandler (Maybe Entry)
lookupEntry d s = do rows <- query "SELECT E.id,title,synopsis,url,content,author_id,category_id,slug,draft,page,date,time,C.id as Cid, C.name as Cname  FROM entries AS E JOIN categories AS C on category_id = C.id WHERE date = ? AND slug = ?" [toSql (show d), toSql s]
                     tags <- mapM getEntryTags rows
                     files <- mapM getEntryFiles rows
                     return $ fmap toEntry $ listToMaybe (zip3 rows tags files)

lookupPageBySlug :: Text -> AppHandler (Maybe Entry)
lookupPageBySlug s = do rows <- query "SELECT E.id,title,synopsis,url,content,author_id,category_id,slug,draft,page,date,time,C.id as Cid, C.name as Cname  FROM entries as E JOIN categories AS C on category_id = C.id WHERE page = true AND slug = ?" [toSql s]
                        tags <- mapM getEntryTags rows
                        files <- mapM getEntryFiles rows
                        return $ fmap toEntry $ listToMaybe (zip3 rows tags files)
                        
newEntry :: Entry -> AppHandler ()
newEntry e = do rows <- query "INSERT INTO entries (title, synopsis, url, content, category_id, author_id, date, time, slug, draft, page) VALUES (?,?,?,?,?,?,?,?,?,?,?) RETURNING id" (init $ fromEntry e)
                let id' = (head rows) ! "id" -- if something goes wrong, we're hosed!
                mapM (\t -> query' "INSERT INTO entry_tags (entry_id, tag_id) VALUES (?,?)" [id', toSql $ tId t]) (S.toList $ eTags e)
                mapM (\f -> query' "INSERT INTO entry_files (entry_id, file_name, file_ext, file_path) VALUES (?,?,?,?)" ([id'] ++ (init $ fromFile f))) (M.toList $ eFiles e)
                return ()

updateEntry :: Date -> Text -> Entry -> AppHandler ()
updateEntry d s e = do query' "UPDATE entries SET title = ?, synopsis = ?, url = ?, content = ?, category_id = ?, author_id = ?, date = ?, time = ?, slug = ?, draft = ?, page = ? WHERE id = ?" (fromEntry e)
                       -- this is clumsy, but for now, we will remove all tags and re-add the ones that exist.
                       -- otherwise, we need to inspect to figure out what has changed
                       query' "DELETE FROM entry_tags WHERE entry_id = ?" [toSql $ eId e]
                       mapM (\t -> query' "INSERT INTO entry_tags (entry_id, tag_id) SELECT ?,? WHERE NOT EXISTS (SELECT 1 FROM entry_tags WHERE entry_id = ? AND tag_id = ?)" (concat $ replicate 2 [toSql $ eId e, toSql $ tId t])) (S.toList $ eTags e)
                       mapM (\f -> do
                                if (trd3 (snd f)) == ""  -- this means it is new, it has no id
                                  then query' "INSERT INTO entry_files (entry_id, file_name, file_ext, file_path) VALUES (?,?,?,?)" ([toSql $ eId e] ++ (init $ fromFile f))
                                  else query' "UPDATE entry_files SET entry_id = ?, file_name = ?, file_ext = ?, file_path = ? WHERE id = ?" ([toSql $ eId e] ++ (fromFile f))) (M.toList $ eFiles e)
                                
                       return ()
  where trd3 (_,_,a) = a

deleteEntry :: Entry -> AppHandler ()
deleteEntry e = do query' "DELETE FROM entries WHERE id = ?" [toSql $ eId e]
                   return ()
                   
deleteEntryImage :: Text -> AppHandler ()
deleteEntryImage imid = do query' "DELETE FROM entry_files WHERE id = ?" [toSql $ imid]
                           return ()

lookupAccountToken :: Text -> Text -> AppHandler (Maybe Bool) -- returns Just admin? or nothing
lookupAccountToken token email = do rows <- query "SELECT admin FROM account_tokens WHERE token = ? AND email = ?" [toSql token, toSql email]
                                    return $ fmap (fromSql.(! "admin")) $ listToMaybe rows
                                    
deleteAccountToken :: Text -> Text -> AppHandler ()
deleteAccountToken token email = do query' "DELETE FROM account_tokens WHERE token = ? AND email = ?" [toSql token, toSql email]
                                    return ()
                                    
newAccountToken :: Text -> Text -> Bool -> AppHandler ()
newAccountToken token email admin = do query' "INSERT INTO account_tokens (token,email,admin) VALUES (?,?,?)" [toSql token, toSql email, toSql admin]
                                       return ()
                                       
allAccountTokens :: AppHandler [((Text,Text),Bool)]
allAccountTokens = do rows <- query "SELECT * FROM account_tokens" []
                      return $ map toAccountToken rows

newResetToken :: Text -> Text -> AppHandler ()
newResetToken token email = do query' "INSERT INTO reset_tokens (token,email) VALUES (?,?)" [toSql token, toSql email]
                               return ()
                               
validResetToken :: Text -> Text -> AppHandler Bool
validResetToken token email = do rows <- query "SELECT * FROM reset_tokens WHERE token = ? AND email = ?" [toSql token, toSql email]
                                 return $ not $ null rows
                                 
deleteResetToken :: Text -> AppHandler ()
deleteResetToken token = do query' "DELETE FROM reset_tokens WHERE token = ?" [toSql token]
                            return ()