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