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