    {-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables, FlexibleInstances #-}
    {-
    Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,
    Anton van Straaten <anton@appsolutions.com>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
    -}

    {- | Types for Gitit modules.
    -}

    module Network.Gitit.Types (
                                PageType(..)
                               , FileStoreType(..)
                               , MathMethod(..)
                               , AuthenticationLevel(..)
                               , Config(..)
                               , Page(..)
                               , SessionKey
                               -- we do not export SessionData constructors, in case we need to extend  SessionData with other data in the future
                               , SessionData
                               , SessionGithubData
                               , sessionData
                               , sessionGithubData
                               , sessionDataGithubStateUrl
                               , sessionUser
                               , sessionGithubState
                               , sessionGithubDestination
                               , User(..)
                               , Sessions(..)
                               , Password(..)
                               , GititState(..)
                               , HasContext
                               , modifyContext
                               , getContext
                               , ContentTransformer
                               , Plugin(..)
                               , PluginData(..)
                               , PluginM
                               , runPluginM
                               , Context(..)
                               , PageLayout(..)
                               , Tab(..)
                               , Recaptcha(..)
                               , Params(..)
                               , Command(..)
                               , WikiState(..)
                               , GititServerPart
                               , Handler
                               , fromEntities
                               , GithubConfig
                               , oAuth2
                               , org
                               , githubConfig) where

    import Control.Monad.Reader (ReaderT, runReaderT, mplus)
    import Control.Monad.State (StateT, runStateT, get, modify)
    import Control.Monad (liftM)
    import System.Log.Logger (Priority(..))
    import Text.Pandoc.Definition (Pandoc)
    import Text.XHtml (Html)
    import qualified Data.Map as M
    import Data.Text (Text)
    import Data.List (intersect)
    import Data.Time (parseTimeM)
    #if MIN_VERSION_time(1,5,0)
    import Data.Time (defaultTimeLocale)
    #else
    import System.Locale (defaultTimeLocale)
    #endif
    import Data.FileStore.Types
    import Network.Gitit.Server
    import Text.HTML.TagSoup.Entity (lookupEntity)
    import Data.Char (isSpace)
    import Network.OAuth.OAuth2

    data PageType = Markdown
                  | CommonMark
                  | RST
                  | LaTeX
                  | HTML
                  | Textile
                  | Org
                  | DocBook
                  | MediaWiki
                    deriving (Read, Show, Eq)

    data FileStoreType = Git | Darcs | Mercurial deriving Show

    data MathMethod = MathML | WebTeX String | RawTeX | MathJax String
                      deriving (Read, Show, Eq)

    data AuthenticationLevel = Never | ForModify | ForRead
                      deriving (Read, Show, Eq, Ord)

    -- | Data structure for information read from config file.
    data Config = Config {
      -- | Path of repository containing filestore
      repositoryPath       :: FilePath,
      -- | Type of repository
      repositoryType       :: FileStoreType,
      -- | Default page markup type for this wiki
      defaultPageType      :: PageType,
      -- | Default file extension for pages in this wiki
      defaultExtension     :: String,
      -- | How to handle LaTeX math in pages?
      mathMethod           :: MathMethod,
      -- | Treat as literate haskell by default?
      defaultLHS           :: Bool,
      -- | Show Haskell code with bird tracks
      showLHSBirdTracks    :: Bool,
      -- | Combinator to set @REMOTE_USER@ request header
      withUser             :: Handler -> Handler,
      -- | Handler for login, logout, register, etc.
      requireAuthentication :: AuthenticationLevel,
      -- | Specifies which actions require authentication.
      authHandler          :: Handler,
      -- | Path of users database
      userFile             :: FilePath,
      -- | Seconds of inactivity before session expires
      sessionTimeout       :: Int,
      -- | Directory containing page templates
      templatesDir         :: FilePath,
      -- | Path of server log file
      logFile              :: FilePath,
      -- | Severity filter for log messages (DEBUG, INFO,
      -- NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY)
      logLevel             :: Priority,
      -- | Path of static directory
      staticDir            :: FilePath,
      -- | Names of plugin modules to load
      pluginModules        :: [String],
      -- | Show table of contents on each page?
      tableOfContents      :: Bool,
      -- | Max size of file uploads
      maxUploadSize        :: Integer,
      -- | Max size of page uploads
      maxPageSize          :: Integer,
      -- | IP address to bind to
      address              :: String,
      -- | Port number to serve content on
      portNumber           :: Int,
      -- | Print debug info to the console?
      debugMode            :: Bool,
      -- | The front page of the wiki
      frontPage            :: String,
      -- | Pages that cannot be edited via web
      noEdit               :: [String],
      -- | Pages that cannot be deleted via web
      noDelete             :: [String],
      -- | Default summary if description left blank
      defaultSummary       :: String,
      -- | Delete summary
      deleteSummary        :: String,
      -- | @Nothing@ = anyone can register.
      -- @Just (prompt, answers)@ = a user will
      -- be given the prompt and must give
      -- one of the answers to register.
      accessQuestion       :: Maybe (String, [String]),
      -- | Use ReCAPTCHA for user registration.
      useRecaptcha         :: Bool,
      recaptchaPublicKey   :: String,
      recaptchaPrivateKey  :: String,
      -- | RPX domain and key
      rpxDomain            :: String,
      rpxKey               :: String,
      -- | Should responses be compressed?
      compressResponses    :: Bool,
      -- | Should responses be cached?
      useCache             :: Bool,
      -- | Directory to hold cached pages
      cacheDir             :: FilePath,
      -- | Map associating mime types with file extensions
      mimeMap              :: M.Map String String,
      -- | Command to send notification emails
      mailCommand          :: String,
      -- | Text of password reset email
      resetPasswordMessage :: String,
      -- | Markup syntax help for edit sidebar
      markupHelp           :: Text,
      -- | Provide an atom feed?
      useFeed              :: Bool,
      -- | Base URL of wiki, for use in feed
      baseUrl              :: String,
      -- | Title of wiki, used in feed
      useAbsoluteUrls      :: Bool,
      -- | Should WikiLinks be absolute w.r.t. the base URL?
      wikiTitle            :: String,
      -- | Number of days history to be included in feed
      feedDays             :: Integer,
      -- | Number of minutes to cache feeds before refreshing
      feedRefreshTime      :: Integer,
      -- | Allow PDF export?
      pdfExport            :: Bool,
      -- | Directory to search for pandoc customizations
      pandocUserData       :: Maybe FilePath,
      -- | Filter HTML through xss-sanitize
      xssSanitize          :: Bool,
      -- | The default number of days in the past to look for \"recent\" activity
      recentActivityDays   :: Int,
      -- | Github client data for authentication (id, secret, callback,
      -- authorize endpoint, access token endpoint)
      githubAuth           :: GithubConfig
      }

    -- | Data for rendering a wiki page.
    data Page = Page {
        pageName        :: String
      , pageFormat      :: PageType
      , pageLHS         :: Bool
      , pageTOC         :: Bool
      , pageTitle       :: String
      , pageCategories  :: [String]
      , pageText        :: String
      , pageMeta        :: [(String, String)]
    } deriving (Read, Show)

    type SessionKey = Integer

    data SessionData = SessionData {
      sessionUser :: Maybe String,
      sessionGithubData :: Maybe SessionGithubData
    } deriving (Read,Show,Eq)

    data SessionGithubData = SessionGithubData {
      sessionGithubState :: String,
      sessionGithubDestination :: String
    } deriving (Read, Show, Eq)

    sessionData :: String -> SessionData
    sessionData user = SessionData (Just user) Nothing

    sessionDataGithubStateUrl :: String -> String -> SessionData
    sessionDataGithubStateUrl githubState destination = SessionData Nothing (Just $ SessionGithubData githubState destination)

    data Sessions a = Sessions {unsession::M.Map SessionKey a}
      deriving (Read,Show,Eq)

    -- Password salt hashedPassword
    data Password = Password { pSalt :: String, pHashed :: String }
      deriving (Read,Show,Eq)

    data User = User {
      uUsername :: String,
      uPassword :: Password,
      uEmail    :: String
    } deriving (Show,Read)

    -- | Common state for all gitit wikis in an application.
    data GititState = GititState {
      sessions       :: Sessions SessionData,
      users          :: M.Map String User,
      templatesPath  :: FilePath,
      renderPage     :: PageLayout -> Html -> Handler,
      plugins        :: [Plugin]
    }

    type ContentTransformer = StateT Context GititServerPart

    data Plugin = PageTransform (Pandoc -> PluginM Pandoc)
                | PreParseTransform (String -> PluginM String)
                | PreCommitTransform (String -> PluginM String)

    data PluginData = PluginData { pluginConfig    :: Config
                                 , pluginUser      :: Maybe User
                                 , pluginRequest   :: Request
                                 , pluginFileStore :: FileStore
                                 }

    type PluginM = ReaderT PluginData (StateT Context IO)

    runPluginM :: PluginM a -> PluginData -> Context -> IO (a, Context)
    runPluginM plugin = runStateT . runReaderT plugin

    data Context = Context { ctxFile            :: String
                           , ctxLayout          :: PageLayout
                           , ctxCacheable       :: Bool
                           , ctxTOC             :: Bool
                           , ctxBirdTracks      :: Bool
                           , ctxCategories      :: [String]
                           , ctxMeta            :: [(String, String)]
                           }

    class (Monad m) => HasContext m where
      getContext    :: m Context
      modifyContext :: (Context -> Context) -> m ()

    instance HasContext ContentTransformer where
      getContext    = get
      modifyContext = modify

    instance HasContext PluginM where
      getContext    = get
      modifyContext = modify

    -- | Abstract representation of page layout (tabs, scripts, etc.)
    data PageLayout = PageLayout
      { pgPageName       :: String
      , pgRevision       :: Maybe String
      , pgPrintable      :: Bool
      , pgMessages       :: [String]
      , pgTitle          :: String
      , pgScripts        :: [String]
      , pgShowPageTools  :: Bool
      , pgShowSiteNav    :: Bool
      , pgMarkupHelp     :: Maybe Text
      , pgTabs           :: [Tab]
      , pgSelectedTab    :: Tab
      , pgLinkToFeed     :: Bool
      }

    data Tab = ViewTab
             | EditTab
             | HistoryTab
             | DiscussTab
             | DiffTab
             deriving (Eq, Show)

    data Recaptcha = Recaptcha {
        recaptchaChallengeField :: String
      , recaptchaResponseField  :: String
      } deriving (Read, Show)

    instance FromData SessionKey where
         fromData = readCookieValue "sid"

    data Params = Params { pUsername     :: String
                         , pPassword     :: String
                         , pPassword2    :: String
                         , pRevision     :: Maybe String
                         , pDestination  :: String
                         , pForUser      :: Maybe String
                         , pSince        :: Maybe UTCTime
                         , pRaw          :: String
                         , pLimit        :: Int
                         , pPatterns     :: [String]
                         , pGotoPage     :: String
                         , pFileToDelete :: String
                         , pEditedText   :: Maybe String
                         , pMessages     :: [String]
                         , pFrom         :: Maybe String
                         , pTo           :: Maybe String
                         , pFormat       :: String
                         , pSHA1         :: String
                         , pLogMsg       :: String
                         , pEmail        :: String
                         , pFullName     :: String
                         , pAccessCode   :: String
                         , pWikiname     :: String
                         , pPrintable    :: Bool
                         , pOverwrite    :: Bool
                         , pFilename     :: String
                         , pFilePath     :: FilePath
                         , pConfirm      :: Bool
                         , pSessionKey   :: Maybe SessionKey
                         , pRecaptcha    :: Recaptcha
                         , pResetCode    :: String
                         , pRedirect     :: Maybe Bool
                         }  deriving Show

    instance FromReqURI [String] where
      fromReqURI s = case fromReqURI s of
                          Just (s' :: String) ->
                                       case reads s' of
                                            ((xs,""):_) -> xs
                                            _           -> Nothing
                          Nothing             -> Nothing

    instance FromData Params where
         fromData = do
             let look' = look
             un <- look' "username"       `mplus` return ""
             pw <- look' "password"       `mplus` return ""
             p2 <- look' "password2"      `mplus` return ""
             rv <- (look' "revision" >>= \s ->
                     return (if null s then Nothing else Just s))
                     `mplus` return Nothing
             fu <- liftM Just (look' "forUser") `mplus` return Nothing
             si <- liftM (parseTimeM True defaultTimeLocale "%Y-%m-%d") (look' "since")
                     `mplus` return Nothing  -- YYYY-mm-dd format
             ds <- look' "destination" `mplus` return ""
             ra <- look' "raw"            `mplus` return ""
             lt <- lookRead "limit"       `mplus` return 100
             pa <- look' "patterns"       `mplus` return ""
             gt <- look' "gotopage"       `mplus` return ""
             ft <- look' "filetodelete"   `mplus` return ""
             me <- looks "message"
             fm <- liftM Just (look' "from") `mplus` return Nothing
             to <- liftM Just (look' "to")   `mplus` return Nothing
             et <- liftM (Just . filter (/='\r')) (look' "editedText")
                     `mplus` return Nothing
             fo <- look' "format"         `mplus` return ""
             sh <- look' "sha1"           `mplus` return ""
             lm <- look' "logMsg"         `mplus` return ""
             em <- look' "email"          `mplus` return ""
             na <- look' "full_name_1"    `mplus` return ""
             wn <- look' "wikiname"       `mplus` return ""
             pr <- (look' "printable" >> return True) `mplus` return False
             ow <- liftM (=="yes") (look' "overwrite") `mplus` return False
             fileparams <- liftM Just (lookFile "file") `mplus` return Nothing
             let (fp, fn) = case fileparams of
                                 Just (x,y,_) -> (x,y)
                                 Nothing      -> ("","")
             ac <- look' "accessCode"     `mplus` return ""
             cn <- (look' "confirm" >> return True) `mplus` return False
             sk <- liftM Just (readCookieValue "sid") `mplus` return Nothing
             rc <- look' "recaptcha_challenge_field" `mplus` return ""
             rr <- look' "recaptcha_response_field" `mplus` return ""
             rk <- look' "reset_code" `mplus` return ""
             rd <- (look' "redirect" >>= \r -> return (case r of
                 "yes" -> Just True
                 "no" -> Just False
                 _ -> Nothing)) `mplus` return Nothing
             return   Params { pUsername     = un
                             , pPassword     = pw
                             , pPassword2    = p2
                             , pRevision     = rv
                             , pForUser      = fu
                             , pSince        = si
                             , pDestination  = ds
                             , pRaw          = ra
                             , pLimit        = lt
                             , pPatterns     = words pa
                             , pGotoPage     = gt
                             , pFileToDelete = ft
                             , pMessages     = me
                             , pFrom         = fm
                             , pTo           = to
                             , pEditedText   = et
                             , pFormat       = fo
                             , pSHA1         = sh
                             , pLogMsg       = lm
                             , pEmail        = em
                             , pFullName     = na
                             , pWikiname     = wn
                             , pPrintable    = pr
                             , pOverwrite    = ow
                             , pFilename     = fn
                             , pFilePath     = fp
                             , pAccessCode   = ac
                             , pConfirm      = cn
                             , pSessionKey   = sk
                             , pRecaptcha    = Recaptcha {
                                  recaptchaChallengeField = rc,
                                  recaptchaResponseField = rr }
                             , pResetCode    = rk
                             , pRedirect     = rd
                             }

    data Command = Command (Maybe String) deriving Show

    instance FromData Command where
         fromData = do
           pairs <- lookPairs
           return $ case map fst pairs `intersect` commandList of
                     []          -> Command Nothing
                     (c:_)       -> Command $ Just c
                   where commandList = ["update", "cancel", "export"]

    -- | State for a single wiki.
    data WikiState = WikiState {
                         wikiConfig    :: Config
                       , wikiFileStore :: FileStore
                       }

    type GititServerPart = ServerPartT (ReaderT WikiState IO)

    type Handler = GititServerPart Response

    -- Unescapes XML entities
    fromEntities :: String -> String
    fromEntities ('&':xs) =
      case lookupEntity ent of
            Just c  -> c ++ fromEntities rest
            Nothing -> '&' : fromEntities xs
        where (ent, rest) = case break (\c -> isSpace c || c == ';') xs of
                                 (zs,';':ys) -> (zs,ys)
                                 _           -> ("",xs)
    fromEntities (x:xs) = x : fromEntities xs
    fromEntities [] = []

    data GithubConfig = GithubConfig { oAuth2 :: OAuth2
                                     , org :: Maybe Text
                                     }

    githubConfig :: OAuth2 -> Maybe Text -> GithubConfig
    githubConfig = GithubConfig