app/Main.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE TemplateHaskell #-}
   3 {-# LANGUAGE DuplicateRecordFields #-}
   4
   5 module Main where
   6
   7 import Data.List (intercalate, zipWith)
   8 import Data.Text hiding (map, init, length, splitAt, foldl, zipWith)
   9 import Data.Text.IO (putStrLn, putStr, writeFile)
  10 import Data.Text.Lazy (toStrict)
  11 import Data.Text.Template
  12 import Data.Time.Clock.POSIX
  13 import Lib
  14 import Prelude hiding (putStrLn, putStr, init, unlines, writeFile, zipWith)
  15 import Prompts
  16 import System.Directory
  17 import System.Environment
  18 import System.Exit
  19 import System.Process
  20 import Data.Aeson
  21 import Data.Aeson.Text
  22 import Util
  23 import Data.Bool (bool)
  24 import Data.Tuple.Curry (uncurryN)
  25 import qualified Data.ByteString.Lazy as BL
  26 import Config
  27 import Control.Monad.Except (throwError)
  28 import Control.Monad.Trans.Class (lift)
  29 import Control.Monad.Trans.Except
  30 import Control.Error.Safe
  31 import Data.Bifunctor
  32 import qualified Data.ByteString.Lazy.UTF8 as BLU
  33
  34 getGlobalProjectDir :: IO FilePath
  35 getGlobalProjectDir = (++ "/.xyz") <$> getHomeDirectory
  36
  37 getGlobalProjectConfigPath :: IO FilePath
  38 getGlobalProjectConfigPath = getGlobalProjectDir >>= return . (++ "/xyz.json")
  39
  40 safeReadFile :: FilePath -> ExceptT Text IO Text
  41 safeReadFile p = (lift $ doesFileExist p) >>= bool (throwError $ pack p +++ ": File does not exist") (lift $ pack <$> readFile p)
  42
  43 safeDecodeJSONFile :: FromJSON a => FilePath -> ExceptT Text IO a
  44 safeDecodeJSONFile f = safeReadFile f >>= (tryRight . first appendFileName . eitherDecode . BLU.fromString . unpack)
  45   where appendFileName s = pack $ f ++ ": " ++ s
  46
  47 getGlobalProjectConfig :: ExceptT Text IO GlobalConfig
  48 getGlobalProjectConfig = lift path >>= safeDecodeJSONFile
  49   where path = (++ "/xyz.json") <$> getGlobalProjectDir
  50
  51 getLocalProjectConfig :: ExceptT Text IO LocalConfig
  52 getLocalProjectConfig = safeDecodeJSONFile "xyz.json"
  53
  54 getEntryTemplate :: Text -> ExceptT Text IO Template
  55 getEntryTemplate t = template <$> (lift path >>= safeReadFile)
  56   where path = (++ "/entry-" ++ (unpack t) ++ ".txt") <$> getGlobalProjectDir
  57
  58 resolveProjectConfig :: ExceptT Text IO ProjectConfig
  59 resolveProjectConfig = getProjectConfig <$> getGlobalProjectConfig <*> getLocalProjectConfig
  60
  61 init :: ExceptT Text IO LocalConfig -> ExceptT Text IO GlobalConfig -> ExceptT Text IO Text
  62 init local global = do
  63   l <- lift $ runExceptT local
  64   g <- lift $ runExceptT global
  65   case (g, l) of
  66     (_, Right _) -> pure "Project already initialised"
  67     (Left _, Left _) -> globalInit >> localInit
  68     (Right _, Left _) -> localInit
  69   where
  70     globalInit = do
  71       lift $ putStrLn "\nWelcome to xyz! Looks like this is your first time here. Let's configure a few things...\n"
  72       editor <- lift editorPrompt
  73       vcs <- lift vcsPrompt
  74       let pushCmdAndRemote = case vcs of
  75             Just (True, x) -> [("pushCommand", "git add . && git commit -m \"$title\""), ("remote", x)]
  76             Nothing -> []
  77
  78       lift $ getGlobalProjectConfigPath >>= flip writeFile (toStrict . encodeToLazyText $ GlobalConfig editor (lookup "pushCommand" pushCmdAndRemote) (lookup "remote" pushCmdAndRemote))
  79       lift $ putStrLn "\nThanks! Now let's continue with initialising your project...\n"
  80
  81     localInit = do
  82       home <- lift $ getHomeDirectory
  83       themes <- lift $ allFilesIn $ home ++ "/.xyz/themes"
  84       projectSpec <- lift $ (\[x,y,z] -> (x, y, z, Nothing, Nothing, Nothing)) <$> fmap snd <$> initPrompt (map pack themes)
  85       let localConfig = uncurryN LocalConfig projectSpec
  86       lift $ writeFile "xyz.json" (toStrict . encodeToLazyText $ localConfig)
  87       config <- resolveProjectConfig
  88       lift $ createDirectory "entries"
  89
  90       case (commitCommand (config :: ProjectConfig), gitRemote (config :: ProjectConfig)) of
  91         (Just cmd, Just remote) -> do
  92           lift $ putStrLn "Initialising project with git"
  93           lift $ mapM_ (callCommand . unpack . (+++ " > /dev/null 2>&1")) ["git init", "git remote add origin " +++ remote, "git add .", "git commit -m \"Initial commit\""]
  94         (_, _) -> return()
  95
  96       pure "Initialised empty project"
  97
  98 build :: ProjectConfig -> ExceptT Text IO Text
  99 build config = (lift $ allFilesIn "entries" >>= writeOutProject config) >> pure "Build successful"
 100
 101 entry :: ProjectConfig -> ExceptT Text IO Text
 102 entry config = do
 103   homeDir <- lift getHomeDirectory
 104   entrySpec <- lift entryPrompt
 105   entryNum <- lift $ fmap (show . (+1) . length) $ allFilesIn "entries"
 106   stamp <- lift $ fmap (pack . show . round) getPOSIXTime
 107   videoTemplate <- getEntryTemplate $ "video"
 108   normalTemplate <- getEntryTemplate $ "normal"
 109
 110   let rawEntry = case entrySpec of
 111         Just (title, videoSpec) -> do
 112           let baseContext = [("timestamp", stamp), ("title", title)]
 113           case videoSpec of
 114             -- TODO: Properly handle the Maybes for video and normal templates
 115             Just (videoId, videoFilename) -> (title, toStrict . render videoTemplate $ context $ baseContext ++ [("videoid", videoId), ("videofilename", videoFilename)])
 116             Nothing -> (title, toStrict . render normalTemplate $ context baseContext)
 117
 118   let fileName = "entries/" ++ entryNum ++ "-" ++ (unpack . slugify $ fst rawEntry) ++ ".txt"
 119   lift $ writeFile fileName $ snd rawEntry
 120
 121   lift $ callCommand $ (unpack (editor (config :: ProjectConfig))) ++ " " ++ fileName
 122   build config
 123
 124   push <- lift pushPrompt
 125   case push of
 126     True -> do
 127       lift $ callCommand . unpack $ "git add . && git commit -m \"" +++ (fst rawEntry) +++ "\" && git push"
 128     False -> return ()
 129
 130   pure "\nThanks for using xyz!"
 131
 132 config :: ProjectConfig -> ExceptT Text IO Text
 133 config config = pure $ "\nProject details:\n" +++ (unlines $ zipWith (+++) ["Name:\t\t", "Description:\t", "Theme:\t\t", "Editor:\t\t", "Commit command:\t"] [n, d, t, e, ccc]) where
 134              n = name (config :: ProjectConfig)
 135              d = description (config :: ProjectConfig)
 136              t = theme (config :: ProjectConfig)
 137              e = editor (config :: ProjectConfig)
 138              cc = commitCommand (config :: ProjectConfig)
 139              ccc = case cc of
 140                Just g -> g
 141                Nothing -> "Not set"
 142
 143 usage :: IO ()
 144 usage =  putStr . ununlines $ [
 145   "usage: xyz <command>",
 146   "Commands:", unlines [
 147       "\tinit\t\tInitialise a new site",
 148       "\tbuild\t\tBuild the site",
 149       "\tentry\t\tInitialise an entry"
 150                        ]
 151   ]
 152
 153 runExceptTAndOutput :: ExceptT Text IO Text -> IO ()
 154 runExceptTAndOutput e = do
 155   result <- runExceptT e
 156   case result of
 157     Left error -> putStrLn error >> (exitWith $ ExitFailure 1)
 158     Right output -> putStrLn output >> exitWith ExitSuccess
 159
 160 main :: IO ()
 161 main = getArgs >>= parse
 162
 163 parse ["init"] = runExceptTAndOutput $ init getLocalProjectConfig getGlobalProjectConfig
 164 parse ["build"] = runExceptTAndOutput $ resolveProjectConfig >>= build
 165 parse ["entry"] = runExceptTAndOutput $ resolveProjectConfig >>= entry
 166 parse ["config"] = runExceptTAndOutput $ resolveProjectConfig >>= config
 167 parse [_] = usage
 168 parse [] = usage