{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>
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
-}

{- | Functions for initializing a Gitit wiki.
-}

module Network.Gitit.Initialize ( initializeGititState
                                , recompilePageTemplate
                                , compilePageTemplate
                                , createStaticIfMissing
                                , createRepoIfMissing
                                , createDefaultPages
                                , createTemplateIfMissing )
where
import System.FilePath ((</>), (<.>))
import Data.Semigroup ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import Data.FileStore
import qualified Data.Map as M
import Network.Gitit.Util (readFileUTF8)
import Network.Gitit.Types
import Network.Gitit.State
import Network.Gitit.Framework
import Network.Gitit.Plugins
import Network.Gitit.Layout (defaultRenderPage)
import Paths_gitit (getDataFileName)
import Control.Exception (throwIO, try)
import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
import Control.Monad ((<=<), unless, forM_, liftM)
import Text.Pandoc hiding (getDataFileName, WARNING)
import System.Log.Logger (logM, Priority(..))
import qualified Text.StringTemplate as ST


-- | Initialize Gitit State.
initializeGititState :: Config -> IO ()
initializeGititState :: Config -> IO ()
initializeGititState Config
conf = do
  let userFile' :: FilePath
userFile' = Config -> FilePath
userFile Config
conf
      pluginModules' :: [FilePath]
pluginModules' = Config -> [FilePath]
pluginModules Config
conf
  plugins' <- [FilePath] -> IO [Plugin]
loadPlugins [FilePath]
pluginModules'

  userFileExists <- doesFileExist userFile'
  users' <- if userFileExists
               then liftM (M.fromList . read . T.unpack) $ readFileUTF8 userFile'
               else return M.empty

  templ <- compilePageTemplate (templatesDir conf)

  updateGititState $ \GititState
s -> GititState
s { sessions      = Sessions M.empty
                             , users         = users'
                             , templatesPath = templatesDir conf
                             , renderPage    = defaultRenderPage templ
                             , plugins       = plugins' }

-- | Recompile the page template.
recompilePageTemplate :: IO ()
recompilePageTemplate :: IO ()
recompilePageTemplate = do
  tempsDir <- (GititState -> FilePath) -> IO FilePath
forall (m :: * -> *) a. MonadIO m => (GititState -> a) -> m a
queryGititState GititState -> FilePath
templatesPath
  ct <- compilePageTemplate tempsDir
  updateGititState $ \GititState
st -> GititState
st{renderPage = defaultRenderPage ct}

--- | Compile a master page template named @page.st@ in the directory specified.
compilePageTemplate :: FilePath -> IO (ST.StringTemplate String)
compilePageTemplate :: FilePath -> IO (StringTemplate FilePath)
compilePageTemplate FilePath
tempsDir = do
  defaultGroup <- FilePath -> IO FilePath
getDataFileName (FilePath
"data" FilePath -> FilePath -> FilePath
</> FilePath
"templates") IO FilePath
-> (FilePath -> IO (STGroup FilePath)) -> IO (STGroup FilePath)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO (STGroup FilePath)
forall a. Stringable a => FilePath -> IO (STGroup a)
ST.directoryGroup
  customExists <- doesDirectoryExist tempsDir
  combinedGroup <-
    if customExists
       -- default templates from data directory will be "shadowed"
       -- by templates from the user's template dir
       then do customGroup <- ST.directoryGroup tempsDir
               return $ ST.mergeSTGroups customGroup defaultGroup
       else do logM "gitit" WARNING $ "Custom template directory not found"
               return defaultGroup
  case ST.getStringTemplate "page" combinedGroup of
        Just StringTemplate FilePath
t    -> StringTemplate FilePath -> IO (StringTemplate FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StringTemplate FilePath
t
        Maybe (StringTemplate FilePath)
Nothing   -> FilePath -> IO (StringTemplate FilePath)
forall a. HasCallStack => FilePath -> a
error FilePath
"Could not get string template"

-- | Create templates dir if it doesn't exist.
createTemplateIfMissing :: Config -> IO ()
createTemplateIfMissing :: Config -> IO ()
createTemplateIfMissing Config
conf' = do
  templateExists <- FilePath -> IO Bool
doesDirectoryExist (Config -> FilePath
templatesDir Config
conf')
  unless templateExists $ do
    createDirectoryIfMissing True (templatesDir conf')
    templatePath <- getDataFileName $ "data" </> "templates"
    -- templs <- liftM (filter (`notElem` [".",".."])) $
    --  getDirectoryContents templatePath
    -- Copy footer.st, since this is the component users
    -- are most likely to want to customize:
    forM_ ["footer.st"] $ \FilePath
t -> do
      FilePath -> FilePath -> IO ()
copyFile (FilePath
templatePath FilePath -> FilePath -> FilePath
</> FilePath
t) (Config -> FilePath
templatesDir Config
conf' FilePath -> FilePath -> FilePath
</> FilePath
t)
      FilePath -> Priority -> FilePath -> IO ()
logM FilePath
"gitit" Priority
WARNING (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Created " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Config -> FilePath
templatesDir Config
conf' FilePath -> FilePath -> FilePath
</> FilePath
t)

-- | Create page repository unless it exists.
createRepoIfMissing :: Config -> IO ()
createRepoIfMissing :: Config -> IO ()
createRepoIfMissing Config
conf = do
  let fs :: FileStore
fs = Config -> FileStore
filestoreFromConfig Config
conf
  repoExists <- IO () -> IO (Either FileStoreError ())
forall e a. Exception e => IO a -> IO (Either e a)
try (FileStore -> IO ()
initialize FileStore
fs) IO (Either FileStoreError ())
-> (Either FileStoreError () -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either FileStoreError ()
res ->
    case Either FileStoreError ()
res of
         Right ()
_               -> do
           FilePath -> Priority -> FilePath -> IO ()
logM FilePath
"gitit" Priority
WARNING (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Created repository in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Config -> FilePath
repositoryPath Config
conf
           Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
         Left FileStoreError
RepositoryExists -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
         Left FileStoreError
e                -> FileStoreError -> IO (ZonkAny 1)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO FileStoreError
e IO (ZonkAny 1) -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  unless repoExists $ createDefaultPages conf

createDefaultPages :: Config -> IO ()
createDefaultPages :: Config -> IO ()
createDefaultPages Config
conf = do
    let fs :: FileStore
fs = Config -> FileStore
filestoreFromConfig Config
conf
        pt :: PageType
pt = Config -> PageType
defaultPageType Config
conf
        toPandoc :: Text -> PandocPure Pandoc
toPandoc = ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
readMarkdown ReaderOptions
forall a. Default a => a
def{ readerExtensions = enableExtension Ext_smart (readerExtensions def) }
        defOpts :: WriterOptions
defOpts = WriterOptions
forall a. Default a => a
def{ writerExtensions = if showLHSBirdTracks conf
                                             then enableExtension
                                                  Ext_literate_haskell
                                                  $ writerExtensions def
                                             else writerExtensions def
                     }
        -- note: we convert this (markdown) to the default page format
        converter :: Text -> IO Text
converter = Either PandocError Text -> IO Text
forall a. Either PandocError a -> IO a
handleError (Either PandocError Text -> IO Text)
-> (Text -> Either PandocError Text) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure Text -> Either PandocError Text)
-> (Text -> PandocPure Text) -> Text -> Either PandocError Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case PageType
pt of
                       PageType
Markdown   -> Text -> PandocPure Text
forall a. a -> PandocPure a
forall (m :: * -> *) a. Monad m => a -> m a
return
                       PageType
LaTeX      -> WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeLaTeX WriterOptions
defOpts (Pandoc -> PandocPure Text)
-> (Text -> PandocPure Pandoc) -> Text -> PandocPure Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> PandocPure Pandoc
toPandoc
                       PageType
HTML       -> WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
defOpts (Pandoc -> PandocPure Text)
-> (Text -> PandocPure Pandoc) -> Text -> PandocPure Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> PandocPure Pandoc
toPandoc
                       PageType
RST        -> WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeRST WriterOptions
defOpts (Pandoc -> PandocPure Text)
-> (Text -> PandocPure Pandoc) -> Text -> PandocPure Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> PandocPure Pandoc
toPandoc
                       PageType
Textile    -> WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeTextile WriterOptions
defOpts (Pandoc -> PandocPure Text)
-> (Text -> PandocPure Pandoc) -> Text -> PandocPure Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> PandocPure Pandoc
toPandoc
                       PageType
Org        -> WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeOrg WriterOptions
defOpts (Pandoc -> PandocPure Text)
-> (Text -> PandocPure Pandoc) -> Text -> PandocPure Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> PandocPure Pandoc
toPandoc
#if MIN_VERSION_pandoc(3,0,0)
                       PageType
DocBook    -> WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeDocBook5 WriterOptions
defOpts (Pandoc -> PandocPure Text)
-> (Text -> PandocPure Pandoc) -> Text -> PandocPure Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> PandocPure Pandoc
toPandoc
#else
                       DocBook    -> writeDocbook5 defOpts <=< toPandoc
#endif
                       PageType
MediaWiki  -> WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeMediaWiki WriterOptions
defOpts (Pandoc -> PandocPure Text)
-> (Text -> PandocPure Pandoc) -> Text -> PandocPure Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> PandocPure Pandoc
toPandoc
                       PageType
CommonMark -> WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeCommonMark WriterOptions
defOpts (Pandoc -> PandocPure Text)
-> (Text -> PandocPure Pandoc) -> Text -> PandocPure Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> PandocPure Pandoc
toPandoc

    welcomepath <- FilePath -> IO FilePath
getDataFileName (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"data" FilePath -> FilePath -> FilePath
</> FilePath
"FrontPage" FilePath -> FilePath -> FilePath
<.> FilePath
"page"
    welcomecontents <- converter =<< readFileUTF8 welcomepath
    helppath <- getDataFileName $ "data" </> "Help" <.> "page"
    helpcontentsInitial <- converter =<< readFileUTF8 helppath
    markuppath <- getDataFileName $ "data" </> "markup" <.> show pt
    helpcontentsMarkup <- converter =<< readFileUTF8 markuppath
    let helpcontents = Text
helpcontentsInitial Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
helpcontentsMarkup
    usersguidepath <- getDataFileName "README.markdown"
    usersguidecontents <- converter =<< readFileUTF8 usersguidepath
    -- include header in case user changes default format:
    let header = Text
"---\nformat: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          FilePath -> Text
T.pack (PageType -> FilePath
forall a. Show a => a -> FilePath
show PageType
pt) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Config -> Bool
defaultLHS Config
conf then Text
"+lhs" else Text
"") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          Text
"\n...\n\n"
    -- add front page, help page, and user's guide
    let auth = FilePath -> FilePath -> Author
Author FilePath
"Gitit" FilePath
""
    createIfMissing fs (frontPage conf <.> defaultExtension conf) auth "Default front page"
      $ header <> welcomecontents
    createIfMissing fs ("Help" <.> defaultExtension conf) auth "Default help page"
      $ header <> helpcontents
    createIfMissing fs ("Gitit User’s Guide" <.> defaultExtension conf) auth "User’s guide (README)"
      $ header <> usersguidecontents

createIfMissing :: FileStore -> FilePath -> Author -> Description -> Text -> IO ()
createIfMissing :: FileStore -> FilePath -> Author -> FilePath -> Text -> IO ()
createIfMissing FileStore
fs FilePath
p Author
a FilePath
comm Text
cont = do
  res <- IO () -> IO (Either FileStoreError ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either FileStoreError ()))
-> IO () -> IO (Either FileStoreError ())
forall a b. (a -> b) -> a -> b
$ FileStore -> FilePath -> Author -> FilePath -> FilePath -> IO ()
forall a.
Contents a =>
FileStore -> FilePath -> Author -> FilePath -> a -> IO ()
create FileStore
fs FilePath
p Author
a FilePath
comm (Text -> FilePath
T.unpack Text
cont)
  case res of
       Right ()
_ -> FilePath -> Priority -> FilePath -> IO ()
logM FilePath
"gitit" Priority
WARNING (FilePath
"Added " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" to repository")
       Left FileStoreError
ResourceExists -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Left FileStoreError
e              -> FileStoreError -> IO (ZonkAny 0)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO FileStoreError
e IO (ZonkAny 0) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Create static directory unless it exists.
createStaticIfMissing :: Config -> IO ()
createStaticIfMissing :: Config -> IO ()
createStaticIfMissing Config
conf = do
  let staticdir :: FilePath
staticdir = Config -> FilePath
staticDir Config
conf
  staticExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
staticdir
  unless staticExists $ do

    let cssdir = FilePath
staticdir FilePath -> FilePath -> FilePath
</> FilePath
"css"
    createDirectoryIfMissing True cssdir
    cssDataDir <- getDataFileName $ "data" </> "static" </> "css"
    -- cssFiles <- liftM (filter (\f -> takeExtension f == ".css")) $ getDirectoryContents cssDataDir
    forM_ ["custom.css"] $ \FilePath
f -> do
      FilePath -> FilePath -> IO ()
copyFile (FilePath
cssDataDir FilePath -> FilePath -> FilePath
</> FilePath
f) (FilePath
cssdir FilePath -> FilePath -> FilePath
</> FilePath
f)
      FilePath -> Priority -> FilePath -> IO ()
logM FilePath
"gitit" Priority
WARNING (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Created " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath
cssdir FilePath -> FilePath -> FilePath
</> FilePath
f)

    {-
    let icondir = staticdir </> "img" </> "icons"
    createDirectoryIfMissing True icondir
    iconDataDir <- getDataFileName $ "data" </> "static" </> "img" </> "icons"
    iconFiles <- liftM (filter (\f -> takeExtension f == ".png")) $ getDirectoryContents iconDataDir
    forM_ iconFiles $ \f -> do
      copyFile (iconDataDir </> f) (icondir </> f)
      logM "gitit" WARNING $ "Created " ++ (icondir </> f)
    -}

    logopath <- getDataFileName $ "data" </> "static" </> "img" </> "logo.png"
    createDirectoryIfMissing True $ staticdir </> "img"
    copyFile logopath $ staticdir </> "img" </> "logo.png"
    logM "gitit" WARNING $ "Created " ++ (staticdir </> "img" </> "logo.png")

    {-
    let jsdir = staticdir </> "js"
    createDirectoryIfMissing True jsdir
    jsDataDir <- getDataFileName $ "data" </> "static" </> "js"
    javascripts <- liftM (filter (`notElem` [".", ".."])) $ getDirectoryContents jsDataDir
    forM_ javascripts $ \f -> do
      copyFile (jsDataDir </> f) (jsdir </> f)
      logM "gitit" WARNING $ "Created " ++ (jsdir </> f)
    -}