1 {-# LANGUAGE DuplicateRecordFields #-}
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
12 import Prelude hiding (putStrLn, putStr, init, unlines, writeFile, zipWith)
14 import System.Directory
15 import System.Environment
19 import Data.Aeson.Text
21 import Data.Bool (bool)
22 import Data.Tuple.Curry (uncurryN)
23 import qualified Data.ByteString.Lazy as BL
25 import Control.Monad.Except (throwError)
26 import Control.Monad.Trans.Class (lift)
27 import Control.Monad.Trans.Except
28 import Control.Error.Safe
30 import qualified Data.ByteString.Lazy.UTF8 as BLU
32 getGlobalProjectDir :: IO FilePath
33 getGlobalProjectDir = (++ "/.xyz") <$> getHomeDirectory
35 getGlobalProjectConfigPath :: IO FilePath
36 getGlobalProjectConfigPath = getGlobalProjectDir >>= return . (++ "/xyz.json")
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)
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
45 getGlobalProjectConfig :: ExceptT Text IO GlobalConfig
46 getGlobalProjectConfig = lift path >>= safeDecodeJSONFile
47 where path = (++ "/xyz.json") <$> getGlobalProjectDir
49 getLocalProjectConfig :: ExceptT Text IO LocalConfig
50 getLocalProjectConfig = safeDecodeJSONFile "xyz.json"
52 getEntryTemplate :: Text -> ExceptT Text IO Template
53 getEntryTemplate t = template <$> (lift path >>= safeReadFile)
54 where path = (++ "/entry-" ++ (unpack t) ++ ".txt") <$> getGlobalProjectDir
56 resolveProjectConfig :: ExceptT Text IO ProjectConfig
57 resolveProjectConfig = getProjectConfig <$> getGlobalProjectConfig <*> getLocalProjectConfig
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
64 (_, Right _) -> pure "Project already initialised"
65 (Left _, Left _) -> globalInit >> localInit
66 (Right _, Left _) -> localInit
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
72 let pushCmdAndRemote = case vcs of
73 Just (True, x) -> [("pushCommand", "git add . && git commit -m \"$title\""), ("remote", x)]
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"
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"
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\""]
94 pure "Initialised empty project"
96 build :: ProjectConfig -> ExceptT Text IO Text
97 build config = (lift $ allFilesIn "entries" >>= writeOutProject config) >> pure "Build successful"
99 entry :: ProjectConfig -> ExceptT Text IO Text
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"
108 let rawEntry = case entrySpec of
109 Just (title, videoSpec) -> do
110 let baseContext = [("timestamp", stamp), ("title", title)]
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)
116 let fileName = "entries/" ++ entryNum ++ "-" ++ (unpack . slugify $ fst rawEntry) ++ ".txt"
117 lift $ writeFile fileName $ snd rawEntry
119 lift $ callCommand $ (unpack (editor (config :: ProjectConfig))) ++ " " ++ fileName
122 push <- lift pushPrompt
125 lift $ callCommand . unpack $ "git add . && git commit -m \"" +++ (fst rawEntry) +++ "\" && git push"
128 pure "\nThanks for using xyz!"
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)
141 data Command = Command {
144 dispatch :: ExceptT Text IO Text
147 commands :: [Command]
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
155 usage :: [Command] -> ExceptT Text IO Text
156 usage c = pure . ununlines $ [
157 "usage: xyz <command>",
159 unlines $ fmap (\x ->"\t" +++ name (x :: Command) +++ ": " +++ description (x :: Command)) c
162 runExceptTAndOutput :: ExceptT Text IO Text -> IO ()
163 runExceptTAndOutput e = do
164 result <- runExceptT e
166 Left error -> putStrLn error >> (exitWith $ ExitFailure 1)
167 Right output -> putStrLn output >> exitWith ExitSuccess
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)
177 main = getArgs >>= runExceptTAndOutput . ((parse commands)) . (fmap pack)