app/Main.hs

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