{-# LANGUAGE
    OverloadedStrings
  , ConstraintKinds
  , FlexibleContexts
  , TemplateHaskell
  , TypeFamilies
  , MultiParamTypeClasses
  , DeriveDataTypeable
  , GeneralizedNewtypeDeriving
  #-}

module Application.Types where

import Application.Links

import Path.Extended
import Data.Url
import qualified Data.TimeMap as TM
import Data.Hashable (Hashable)
import Data.Typeable
import Data.Data
import Data.SafeCopy (base, deriveSafeCopy)
import Data.Acid
import Data.IxSet
import Data.Monoid
import Data.Maybe (isJust)
import Data.UUID (UUID)
import qualified Text.Pandoc            as P
import qualified Data.IxSet             as Ix
import qualified Data.ByteString.Lazy   as LBS
import qualified Data.Vault.Lazy        as V
import qualified Data.Text              as T
import Control.Monad.Logger
import Control.Monad.Trans.Control
import Control.Monad.Catch
import Control.Monad.Reader
import Control.Monad.State
import Control.Concurrent.STM
import System.Directory (doesFileExist)
import Lucid hiding (Term)

import Test.QuickCheck


newtype Term = Term
  { getTerm :: String
  } deriving (Show, Eq, Ord, Data, Typeable)

$(deriveSafeCopy 0 'base ''Term)


newtype Email = Email
  { getEmail :: String
  } deriving (Show, Eq, Ord, Data, Typeable)

$(deriveSafeCopy 0 'base ''Email)


data Definition = Definition
  { defnTerm   :: Term
  , defnDefn   :: String
  , defnAuthor :: Email
  } deriving (Show, Eq, Ord, Data, Typeable)

$(deriveSafeCopy 0 'base ''Definition)



newtype GoogleUserId = GoogleUserId
  { getGoogleUserId :: T.Text
  } deriving (Show, Eq, Ord, Data, Typeable)

$(deriveSafeCopy 0 'base ''GoogleUserId)

instance Indexable Definition where
  empty = ixSet
    [ ixFun $ \def -> [defnTerm def]
    , ixFun $ \def -> [defnDefn def]
    , ixFun $ \def -> [defnAuthor def]
    ]


data AccessPrivs
  = UserPrivs
  | AdminPrivs
  deriving (Show, Eq, Ord, Data, Typeable)

$(deriveSafeCopy 0 'base ''AccessPrivs)



newtype SessionId = SessionId
  { getSessionId :: Integer
  } deriving (Eq, Ord, Enum, Read, Num, Hashable, Arbitrary, Data, Typeable)

instance Show SessionId where
  show (SessionId s) = show s


$(deriveSafeCopy 0 'base ''SessionId)

data User = User
  { userId          :: GoogleUserId
  , userEmail       :: Email
  , userSession     :: Maybe SessionId
  , userAccessPrivs :: AccessPrivs
  } deriving (Show, Eq, Ord, Data, Typeable)

$(deriveSafeCopy 0 'base ''User)

instance Indexable User where
  empty = ixSet
    [ ixFun $ \u -> [userId u]
    , ixFun $ \u -> [userEmail u]
    , ixFun $ \u -> [userSession u]
    , ixFun $ \u -> [userAccessPrivs u]
    ]


newtype Glossary = Glossary
  { getGlossary :: IxSet Definition
  } deriving (Show, Eq, Data, Typeable)

$(deriveSafeCopy 0 'base ''Glossary)

initialGlossary :: Glossary
initialGlossary = Glossary empty


newtype UserBase = UserBase
  { getUserBase :: IxSet User
  } deriving (Show, Eq, Data, Typeable)

$(deriveSafeCopy 0 'base ''UserBase)

initialUserBase :: UserBase
initialUserBase = UserBase empty



-- * Database Manipulation


addDefn :: Definition -> Update Glossary ()
addDefn d = do
  (Glossary g) <- get
  put . Glossary $ updateIx (defnTerm d) d g

changeDefnOrNew :: Email -> Term -> String -> Update Glossary (Maybe Definition)
changeDefnOrNew e t d = do
  (Glossary g) <- get
  case getOne $ g @= t of
    Nothing -> do
      let def = Definition t d e
      addDefn def
      return (Just def)
    Just (Definition t' d' e') ->
      if e == e'
      then do let def = Definition t d e
              put . Glossary $ updateIx t def g
              return (Just def)
      else return Nothing

getDefn :: Term -> Query Glossary (Maybe Definition)
getDefn t = do
  (Glossary g) <- ask
  return $ getOne (g @= t)

getAllDefs :: Query Glossary [Definition]
getAllDefs = do
  (Glossary g) <- ask
  return $ toAscList (Ix.Proxy :: Ix.Proxy Term) g

rmDef :: Term -> Update Glossary ()
rmDef t = do
  (Glossary g) <- get
  put . Glossary $ deleteIx t g

$(makeAcidic ''Glossary
  [ 'addDefn
  , 'changeDefnOrNew
  , 'getDefn
  , 'getAllDefs
  , 'rmDef
  ])



addUser :: User -> Update UserBase ()
addUser u = do
  (UserBase us) <- get
  put . UserBase $ updateIx (userEmail u) u us

changeSession :: Email -> Maybe SessionId -> Update UserBase ()
changeSession e mSid = do
  (UserBase us) <- get
  case getOne $ us @= e of
    Nothing -> return ()
    Just u  -> put . UserBase $ updateIx e (u { userSession = mSid }) us

changeSessionOrNew :: GoogleUserId -> Email -> Maybe SessionId -> Update UserBase ()
changeSessionOrNew g e mSid = do
  (UserBase us) <- get
  case getOne $ us @= e of
    Nothing -> put . UserBase $ insert (User g e mSid UserPrivs) us
    Just u  -> put . UserBase $ updateIx e (u { userSession = mSid }) us

filterSession :: [SessionId] -> Update UserBase ()
filterSession sids = do
  (UserBase us) <- get
  put . UserBase . Ix.fromList $ filter go (Ix.toList us)
  where
    go (User _ _ (Just sid) _) = sid `elem` sids
    go _ = False

changeAccessPrivs :: AccessPrivs -> Email -> Update UserBase Bool
changeAccessPrivs w e = do
  (UserBase us) <- get
  case getOne $ us @= e of
    Nothing -> return False
    Just u  -> do
      put . UserBase $ updateIx e (u { userAccessPrivs = w }) us
      return True

getAllUsers :: Query UserBase [User]
getAllUsers = do
  (UserBase us) <- ask
  return $ toAscList (Ix.Proxy :: Ix.Proxy Email) us

rmUser :: Email -> Update UserBase ()
rmUser e = do
  (UserBase us) <- get
  put . UserBase $ deleteIx e us

findLoggedInUser :: SessionId -> Query UserBase (Maybe User)
findLoggedInUser sid = do
  (UserBase us) <- ask
  return . getOne $ us @= (Just sid)

userLoggedIn :: GoogleUserId -> Query UserBase Bool
userLoggedIn gid = do
  (UserBase us) <- ask
  case getOne $ us @= gid of
    Nothing -> return False
    Just u  -> return $ isJust (userSession u)


$(makeAcidic ''UserBase
  [ 'addUser
  , 'changeSession
  , 'changeSessionOrNew
  , 'filterSession
  , 'changeAccessPrivs
  , 'getAllUsers
  , 'rmUser
  , 'findLoggedInUser
  , 'userLoggedIn
  ])

-- * Application Stack

type AppM = LoggingT (ReaderT Env IO)

runAppT :: AppM a -> Env -> IO a
runAppT hs = runReaderT $ runStderrLoggingT hs

type AppTemplateT m = AbsoluteUrlT m

runAppTemplateT :: AppTemplateT m a -> UrlAuthority -> m a
runAppTemplateT = runAbsoluteUrlT


-- | Utilities available throughout the app
type MonadApp m =
  ( MonadIO m
  , MonadThrow m
  , MonadLogger m
  , MonadReader Env m
  , MonadUrl Abs File m
  , MonadBaseControl IO m
  )


-- * Supported Upload Encodings

data UploadEncoding
  = AsJSON
  | AsURLEncoded
  deriving (Show, Eq)


-- * Application Configuration

-- The configuration environment accessible throughout our application
data Env = Env
  { envAuthority    :: {-# UNPACK #-} !UrlAuthority -- ^ The compiled hostname and port
  , envCwd          :: !(Path Abs Dir)              -- ^ The current working directory
  , envStatic       :: !(Path Abs Dir)              -- ^ The static folder
  , envGoogleId     :: {-# UNPACK #-} !String       -- ^ The google app id
  , envProd         :: {-# UNPACK #-} !Bool         -- ^ Whether or not the application is in production-mode
  , envSessionKey   :: !(V.Key SessionId)           -- ^ The key used for seeing which session a request belongs to
  , envSessionId    :: !(TVar SessionId)            -- ^ The next session id
  , envSessionCache :: !(TM.TimeMap SessionId UUID)
  , envGlossaryDB   :: !(AcidState Glossary)
  , envUsersDB      :: !(AcidState UserBase)
  , envPandoc       :: {-# UNPACK #-} !PandocEnv    -- ^ All the loaded pandoc files
  }

data PandocEnv = PandocEnv
  { envPandocDocs   :: {-# UNPACK #-} !DocsEnv      -- ^ The markdown for @docs/@
  , envPandocHome   :: {-# UNPACK #-} !HomeEnv      -- ^ The markdown for @home/@
  }

data DocsEnv = DocsEnv
  { envDocsDocsIntro          :: P.Pandoc
  , envDocsHaskellEdu         :: P.Pandoc
  , envDocsGettingStarted     :: P.Pandoc
  , envDocsUrlMatching        :: P.Pandoc
  , envDocsPredicates         :: P.Pandoc
  , envDocsRouteCombinators   :: P.Pandoc
  , envDocsHttpVerbs          :: P.Pandoc
  , envDocsUploadingData      :: P.Pandoc
  , envDocsResponding         :: P.Pandoc
  , envDocsSensitiveLocs      :: P.Pandoc
  , envDocsSessions           :: P.Pandoc
  , envDocsMonadTrans         :: P.Pandoc
  , envDocsCatchingExceptions :: P.Pandoc
  }

data HomeEnv = HomeEnv
  { envHomeMainPanel  :: P.Pandoc
  , envHomeCodeSample :: P.Pandoc
  }

envDocsIntro, envHaskellEdu, envGettingStarted :: Env -> P.Pandoc
envUrlMatching, envPredicates, envRouteCombinators, envHttpVerbs :: Env -> P.Pandoc
envUploadingData, envResponding, envSensitiveLocs, envSessions, envMonadTrans :: Env -> P.Pandoc
envCatchingExceptions, envMainPanel, envCodeSample :: Env -> P.Pandoc

envDocsIntro          = envDocsDocsIntro          . envPandocDocs . envPandoc
envHaskellEdu         = envDocsHaskellEdu         . envPandocDocs . envPandoc
envGettingStarted     = envDocsGettingStarted     . envPandocDocs . envPandoc
envUrlMatching        = envDocsUrlMatching        . envPandocDocs . envPandoc
envPredicates         = envDocsPredicates         . envPandocDocs . envPandoc
envRouteCombinators   = envDocsRouteCombinators   . envPandocDocs . envPandoc
envHttpVerbs          = envDocsHttpVerbs          . envPandocDocs . envPandoc
envUploadingData      = envDocsUploadingData      . envPandocDocs . envPandoc
envResponding         = envDocsResponding         . envPandocDocs . envPandoc
envSensitiveLocs      = envDocsSensitiveLocs      . envPandocDocs . envPandoc
envSessions           = envDocsSessions           . envPandocDocs . envPandoc
envMonadTrans         = envDocsMonadTrans         . envPandocDocs . envPandoc
envCatchingExceptions = envDocsCatchingExceptions . envPandocDocs . envPandoc

envMainPanel  = envHomeMainPanel  . envPandocHome . envPandoc
envCodeSample = envHomeCodeSample . envPandocHome . envPandoc


-- | Reads markdown
pandocFile :: Path Abs Dir -- Current working directory
           -> Path Rel File
           -> IO P.Pandoc
pandocFile cwd file = do
  content <- parseRelDir "content/"
  let md = toFilePath (cwd </> content </> file)
  exists  <- doesFileExist md
  if exists
  then do let opts = P.def
          eMd <- P.readMarkdown opts <$> readFile md
          case eMd of
            Left err -> throwM err
            Right p  -> return $! p
  else throwM $ userError $ "Markdown file `"
                         ++ toFilePath file
                         ++ "` doesn't exist inside `"
                         ++ toFilePath (cwd </> content)
                         ++ "`."



instance Show Env where
  show (Env a c s g p _ _ _ _ _ _) = "\n"
   ++ "\tenvAuthority = " ++ show a ++ "\n"
   ++ "\tenvCwd       = " ++ show c ++ "\n"
   ++ "\tenvStatic    = " ++ show s ++ "\n"
   ++ "\tenvGoogleId  = " ++ show g ++ "\n"
   ++ "\t\t in " ++ if p then "PRODUCTION"
                         else "DEVELOPMENT" ++ "\n"


data TemplateEnv = TemplateEnv
  { envCurrentUser :: !(Maybe User)
  , envCurrentPage :: !(Maybe AppLinks)
  } deriving (Show, Eq)



-- * Error Types

data UploadError
  = UploadTooLarge
  | NoChunkedBody
  | FailedJSONParse        LBS.ByteString
  | FailedURLEncodedParse  LBS.ByteString
  | NoIdentifier
  | EntityNonexistent
  deriving (Show, Eq, Typeable)

instance Exception UploadError


data GoogleError
  = NoGoogleToken
  | NotGoogleAppID
  | InvalidGoogleToken
  | GoogleNoAud
  | GoogleNoUserId
  | GoogleNoUserEmail
  | GoogleIdMismatch
  deriving (Show, Eq, Typeable)

instance Exception GoogleError


data AuthError
  = NeedsAuthHeaders
  | ExpiredNonce
  | AttemptedSessionDelete
  | AlreadyLoggedIn
  | UserNotLoggedIn
  | NoSession
  | NoUserInfo
  | NoWriteAccess
  | NoAdminAccess
  deriving (Show, Eq, Typeable)

instance Exception AuthError


