module Rakka.Storage.Repos
    ( findAllPagesInRevision
    , findChangedPagesAtRevision
    , loadPageInRepository
    , putPageIntoRepository
    , deletePageFromRepository
    )
    where

import           Codec.Binary.UTF8.String
import           Control.Exception
import           Control.Monad
import           Data.List
import qualified Data.Map as M
import           Data.Maybe
import           Data.Set (Set)
import qualified Data.Set as S hiding (Set)
import           Data.Time
import           Network.HTTP.Lucu hiding (redirect)
import           Rakka.Page
import           Rakka.SystemConfig
import           Rakka.Utils
import           Rakka.W3CDateTime
import           Subversion.Error
import           Subversion.FileSystem
import           Subversion.FileSystem.DirEntry
import           Subversion.FileSystem.Revision
import           Subversion.FileSystem.Root
import           Subversion.FileSystem.Transaction
import           Subversion.Repository
import           Subversion.Types
import           System.FilePath.Posix


mkPagePath :: PageName -> FilePath
mkPagePath name
    = "/pages" </> encodePageName name <.> "page"


findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName)
findAllPagesInRevision repos rev
    = do fs <- getRepositoryFS repos
         withRevision fs rev
             $ do exists <- isDirectory root
                  if exists then
                      traverse root
                    else
                      return S.empty
    where
      root :: FilePath
      root = "/pages"

      traverse :: FilePath -> Rev (Set PageName)
      traverse dir
          = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions

      traverse' :: FilePath -> DirEntry -> Rev (Set PageName)
      traverse' dir entry
          = let path = dir </> entName entry
            in
              do kind <- checkPath path
                 case kind of
                   NoNode   -> return S.empty
                   FileNode -> return $ S.singleton (decodePath path)
                   DirNode  -> traverse path

      decodePath :: FilePath -> PageName
      decodePath = decodePageName . makeRelative root . dropExtension


findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
findChangedPagesAtRevision repos rev
    = do fs <- getRepositoryFS repos
         withRevision fs rev
             $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst
    where
      accumulatePages :: Set PageName -> FilePath -> Set PageName
      accumulatePages s path
          | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path
              = let encoded = makeRelative "/pages" $ dropExtension path
                    name    = decodePageName encoded
                in
                  S.insert name s
          | otherwise
              = s


loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
loadPageInRepository repos name rev
    = do fs   <- getRepositoryFS repos
         rev' <- case rev of
                   Nothing -> getYoungestRev fs
                   Just r  -> return r
         withRevision fs rev'
             $ do exists <- isFile path
                  case exists of
                    True
                        -> return . Just =<< loadPage'
                    False
                        -> return Nothing
    where
      path :: FilePath
      path = mkPagePath name

      loadPage' :: Rev Page
      loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type")
                     case mType of
                       Just (MIMEType "application" "x-rakka-redirection" _)
                           -> loadPageRedirect
                       _
                           -> loadPageEntity

      loadPageEntity :: Rev Page
      loadPageEntity
          = do props   <- getNodePropList path
               hist    <- getNodeHistory True path
               content <- getFileContentsLBS path
               
               let pageRev  = fst $ head hist
                   mimeType = read
                              $ fromMaybe "text/x-rakka"
                              $ fmap chomp (lookup "svn:mime-type" props)

               lastMod <- getRevisionProp "svn:date"
                          >>= return . fromJust . parseW3CDateTime . chomp . fromJust

               return Entity {
                            entityName       = name
                          , entityType       = mimeType
                          , entityLanguage   = fmap chomp (lookup "rakka:lang" props)
                          , entityIsTheme    = any ((== "rakka:isTheme") . fst) props
                          , entityIsFeed     = any ((== "rakka:isFeed") . fst) props
                          , entityIsLocked   = any ((== "rakka:isLocked") . fst) props
                          , entityIsBinary   = case mimeType of
                                                 MIMEType "text" _ _
                                                     -> any ((== "rakka:isBinary") . fst) props
                                                 _
                                                     -> True
                          , entityRevision   = pageRev
                          , entityLastMod    = zonedTimeToUTC lastMod
                          , entitySummary    = lookup "rakka:summary" props
                          , entityOtherLang  = fromMaybe M.empty
                                             $ fmap
                                                   (M.fromList . fromJust . deserializeStringPairs)
                                                   (lookup "rakka:otherLang" props)
                          , entityContent    = content                                             
                          , entityUpdateInfo = undefined
                          }
      
      loadPageRedirect :: Rev Page
      loadPageRedirect
          = do hist    <- getNodeHistory True path
               content <- getFileContents path

               let pageRev = fst $ head hist
                   dest    = chomp $ decodeString content

               lastMod <- getRevisionProp "svn:date"
                          >>= return . fromJust . parseW3CDateTime . chomp . fromJust

               return Redirection {
                            redirName       = name
                          , redirDest       = dest
                          , redirRevision   = pageRev
                          , redirLastMod    = zonedTimeToUTC lastMod
                          , redirUpdateInfo = undefined
                          }


putPageIntoRepository :: Repository -> Page -> IO StatusCode
putPageIntoRepository repos page
    = filterSvnError $
      do let name = pageName page
         ret <- case pageUpdateInfo page of
                  Just ui
                      -> doReposTxn
                         repos
                         (uiOldRevision ui)
                         "[Rakka]"
                         (Just "Automatic commit by Rakka for page update")
                         $ do case uiOldName ui of
                                Nothing      -> return ()
                                Just oldName -> renamePage (uiOldRevision ui) oldName name
                              updatePage name
                  Nothing
                      -> do fs  <- getRepositoryFS repos
                            rev <- getYoungestRev fs
                            doReposTxn repos
                                       rev
                                       "[Rakka]"
                                       (Just "Automatic commit by Rakka for page creation")
                                       $ do createPage name
                                            updatePage name
         case ret of
           Left  _ -> return Conflict
           Right _ -> return Created
    where
      renamePage :: RevNum -> PageName -> PageName -> Txn ()
      renamePage oldRev oldName newName
          = do let oldPath = mkPagePath oldName
                   newPath = mkPagePath newName
               createParentDirectories newPath
               copyEntry oldRev oldPath newPath
               deleteEntry oldPath
               deleteEmptyParentDirectories oldPath

      createPage :: PageName -> Txn ()
      createPage name
          = do let path = mkPagePath name
               createParentDirectories path
               makeFile path

      updatePage :: PageName -> Txn ()
      updatePage name
          | isRedirect page = updatePageRedirect name
          | isEntity   page = updatePageEntity name
          | otherwise       = fail "neither redirection nor page"

      updatePageRedirect :: PageName -> Txn ()
      updatePageRedirect name
          = do let path = mkPagePath name
               setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
               setNodeProp path "rakka:lang"      Nothing
               setNodeProp path "rakka:isTheme"   Nothing
               setNodeProp path "rakka:isFeed"    Nothing
               setNodeProp path "rakka:isLocked"  Nothing
               setNodeProp path "rakka:isBinary"  Nothing
               setNodeProp path "rakka:summary"   Nothing
               setNodeProp path "rakka:otherLang" Nothing
               applyText path Nothing (encodeString (redirDest page) ++ "\n")

      updatePageEntity :: PageName -> Txn ()
      updatePageEntity name
          = do let path = mkPagePath name
               setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
               setNodeProp path "rakka:lang"      (entityLanguage page)
               setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
               setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
               setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
               setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
               setNodeProp path "rakka:summary"   (entitySummary page)
               setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
                                                   in
                                                     if M.null otherLang then
                                                         Nothing
                                                     else
                                                         Just (serializeStringPairs $ M.toList otherLang))
               applyTextLBS path Nothing (entityContent page)

      encodeFlag :: Bool -> Maybe String
      encodeFlag True  = Just "*"
      encodeFlag False = Nothing


createParentDirectories :: FilePath -> Txn ()
createParentDirectories path
    = do let parentPath = takeDirectory path
         kind <- checkPath parentPath
         case kind of
           NoNode   -> do createParentDirectories parentPath
                          makeDirectory parentPath
           FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
           DirNode  -> return ()


deletePageFromRepository :: Repository -> PageName -> IO StatusCode
deletePageFromRepository repos name
    = filterSvnError $
      do let path = mkPagePath name
         fs     <- getRepositoryFS repos
         rev    <- getYoungestRev fs
         exists <- withRevision fs rev $ isFile path
         if exists then
             do doReposTxn repos
                           rev
                           "[Rakka]"
                           (Just "Automatic commit by Rakka for page deleting")
                           $ do deleteEntry path
                                deleteEmptyParentDirectories path
                return NoContent
           else
             return NotFound


deleteEmptyParentDirectories :: FilePath -> Txn ()
deleteEmptyParentDirectories path
    = do let parentPath = takeDirectory path
         contents <- getDirEntries parentPath
         when (null contents)
                  $ do deleteEntry parentPath
                       deleteEmptyParentDirectories parentPath


filterSvnError :: IO a -> IO a
filterSvnError f = catchDyn f rethrow
    where
      rethrow :: SvnError -> IO a
      rethrow err
          = let code = svnErrCode err
                msg  = svnErrMsg  err
            in
              fail $ "SvnError: " ++ (show code) ++ ": " ++ msg