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