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
  33 main :: IO ()
  34 main = getArgs >>= parse
  35
  36 getGlobalProjectDir :: IO FilePath
  37 getGlobalProjectDir = getHomeDirectory >>= return . (++ "/.xyz")
  38
  39 getGlobalProjectConfigPath :: IO FilePath
  40 getGlobalProjectConfigPath = getGlobalProjectDir >>= return . (++ "/xyz.json")
  41
  42 getGlobalProjectConfig :: IO (Maybe GlobalConfig)
  43 getGlobalProjectConfig =  getGlobalProjectConfigPath >>= (\path -> doesFileExist path >>= bool (return Nothing) (BL.readFile path >>= return . decode))
  44
  45 getLocalProjectConfig :: IO (Maybe LocalConfig)
  46 getLocalProjectConfig = doesFileExist "xyz.json" >>= bool (return Nothing) (BL.readFile "xyz.json" >>= return . decode)
  47
  48 resolveProjectConfig :: IO (Maybe ProjectConfig)
  49 resolveProjectConfig = do
  50   l <- getLocalProjectConfig
  51   g <- getGlobalProjectConfig
  52
  53   case (l, g) of
  54     (Just l, Just g) -> return . Just $ getProjectConfig g l
  55     (Just _, Nothing) -> fail "Busted global config"
  56     (Nothing, Just _) -> fail "Busted local config"
  57     _ -> fail "All configs are busted"
  58
  59 continueIfInvalidProject :: IO () -> IO ()
  60 continueIfInvalidProject next = doesFileExist "xyz.json" >>= bool next (putStrLn "Project already initialised")
  61
  62 initGlobalIfNeeded :: IO () -> IO ()
  63 initGlobalIfNeeded next = getGlobalProjectConfigPath >>= doesFileExist >>= bool globalInit (return ()) >> next
  64
  65 globalInit :: IO ()
  66 globalInit = do
  67   home <- getHomeDirectory
  68   putStrLn "\nWelcome to xyz! Looks like this is your first time here. Let's configure a few things...\n"
  69   editor <- editorPrompt
  70   vcs <- vcsPrompt
  71   let pushCmdAndRemote = case vcs of
  72         Just (True, x) -> [("pushCommand", "git add . && git commit -m \"$title\""), ("remote", x)]
  73         Nothing -> []
  74
  75   getGlobalProjectConfigPath >>= flip writeFile (toStrict . encodeToLazyText $ GlobalConfig editor (lookup "pushCommand" pushCmdAndRemote) (lookup "remote" pushCmdAndRemote))
  76   putStrLn "\nThanks! Now let's continue with initialising your project...\n"
  77
  78 init :: IO ()
  79 init = do
  80   home <- getHomeDirectory
  81   themes <- allFilesIn $ home ++ "/.xyz/themes"
  82   projectSpec <- (initPrompt (map pack themes)) >>= return . fmap snd >>= (\[x,y,z] -> return (x, y, z, Nothing, Nothing, Nothing))
  83   let localConfig = uncurryN LocalConfig projectSpec
  84   writeFile "xyz.json" (toStrict . encodeToLazyText $ localConfig)
  85   config <- resolveProjectConfig
  86
  87   case config of
  88     Just projectConfig -> do
  89       createDirectory "entries"
  90
  91       case (commitCommand (projectConfig :: ProjectConfig), gitRemote (projectConfig :: ProjectConfig)) of
  92         (Just cmd, Just remote) -> do
  93           mapM_ (callCommand . unpack . ((+++) " > /dev/unll")) ["git init", "git remote add origin " +++ remote, "git add . && git commit -m \"Initial commit\""]
  94         (_, _) -> return()
  95
  96       putStrLn "\nInitialised empty project"
  97     Nothing -> do
  98       putStrLn "\nSomething went real wrong"
  99
 100 build :: ProjectConfig -> IO ()
 101 build config = allFilesIn "entries" >>= (writeOutProject config) >> putStrLn "Build successful"
 102
 103 entry :: ProjectConfig -> IO ()
 104 entry config = do
 105   homeDir <- getHomeDirectory
 106   entrySpec <- entryPrompt
 107   entryNum <- fmap (show . (+1) . length) $ allFilesIn "entries"
 108   stamp <- fmap (pack . show . round) getPOSIXTime
 109   videoTemplate <- readFile (homeDir ++ "/.xyz/entry-video.txt") >>= return . template . fromString
 110   normalTemplate <- readFile (homeDir ++ "/.xyz/entry.txt") >>= return . template . fromString
 111
 112   let rawEntry = case entrySpec of
 113         Just (title, videoSpec) -> do
 114           let baseContext = [("timestamp", stamp), ("title", title)]
 115           case videoSpec of
 116             Just (videoId, videoFilename) -> (title, toStrict . render videoTemplate $ context $ baseContext ++ [("videoid", videoId), ("videofilename", videoFilename)])
 117             Nothing -> (title, toStrict . render normalTemplate $ context baseContext)
 118
 119   let fileName = "entries/" ++ entryNum ++ "-" ++ (unpack . slugify $ fst rawEntry) ++ ".txt"
 120   writeFile fileName $ snd rawEntry
 121
 122   callCommand $ "nano " ++ fileName
 123
 124   push <- pushPrompt
 125   case push of
 126     True -> do callCommand . unpack $ "git add . && git commit -m \"" +++ (fst rawEntry) +++ "\" && git push"
 127     False -> return ()
 128
 129   putStrLn "\nThanks for using xyz!"
 130
 131 config :: ProjectConfig -> IO ()
 132 config config = (putStrLn "\nProject details:\n") >> (putStr . unlines $ zipWith (+++) ["Name:\t\t", "Description:\t", "Theme:\t\t", "Editor:\t\t", "Commit command:\t"] [n, d, t, e, ccc]) where
 133              n = name (config :: ProjectConfig)
 134              d = description (config :: ProjectConfig)
 135              t = theme (config :: ProjectConfig)
 136              e = editor (config :: ProjectConfig)
 137              cc = commitCommand (config :: ProjectConfig)
 138              ccc = case cc of
 139                Just g -> g
 140                Nothing -> "Not set"
 141
 142 usage :: IO ()
 143 usage =  putStr . ununlines $ [
 144   "usage: xyz <command>",
 145   "Commands:", unlines [
 146       "\tinit\t\tInitialise a new site",
 147       "\tbuild\t\tBuild the site",
 148       "\tentry\t\tInitialise an entry"
 149                        ]
 150   ]
 151
 152 gogogo :: (ProjectConfig -> IO ()) -> Maybe ProjectConfig -> IO ()
 153 gogogo next projectConfig = case projectConfig of
 154   Just config -> next config
 155   _ -> fail "This does not appear to be a vailid project directory" -- Never executes, the cases in resolveProjectConfig will fail first.
 156
 157 parse ["init"] =  initGlobalIfNeeded (continueIfInvalidProject init) >> exitSuccess
 158 parse ["build"] = resolveProjectConfig >>= (gogogo build) >> exitSuccess
 159 parse ["entry"] = resolveProjectConfig >>= (gogogo entry) >> exitSuccess
 160 parse ["config"] = resolveProjectConfig >>= (gogogo config) >> exitSuccess
 161 parse [_] = usage >> exit
 162 parse [] = usage >> exit
 163
 164 exit = exitWith ExitSuccess