Script to backup github repos and gists. My first Haskell script, it's very ugly but works in simple cases (no api pagination support, bad messages...)

github-backup.hs

#!/usr/bin/env runhaskell

{-# LANGUAGE OverloadedStrings#-}

-- Packages required:
-- aeson 1.4.1.0
-- http-conduit 2.3.2
-- turtle 1.5.12
import qualified Data.ByteString.Lazy as B
import Data.Text
import Data.List ((\\), intersect)
import Network.HTTP.Conduit
import Turtle
import Data.Scientific (Scientific, formatScientific, FPFormat(Fixed))
import Data.Aeson
import Control.Applicative (empty)
import Data.Maybe (fromMaybe)
import qualified Control.Foldl as Fold

jsonURL :: String
jsonURL = "https://api.github.com/users/"

gistsDir :: Turtle.FilePath
gistsDir = "gists"

reposDir :: Turtle.FilePath
reposDir = "repos"

defaultDir :: Turtle.FilePath
defaultDir = "github_backup"

userAgent :: String
userAgent = "haskell-backup"

optsParser :: Parser (Text, Maybe Turtle.FilePath)
optsParser = (,) <$>      argText "user" "User to back up"
             <*>          optional (argPath "dir" "The backup dir to use (will be created if it doesn't exist)")

data Gist = Gist {
    gitPullUrl :: Text,
    gistId :: Text,
    idPath :: Turtle.FilePath
} deriving (Show)

instance FromJSON Gist where
    parseJSON (Object v) = Gist <$> v .: "git_pull_url" <*> v .: "id" <*> fmap getPath (v .: "id")
    parseJSON _ = Control.Applicative.empty

data Repo = Repo {
    repoId :: Scientific,
    repoPath :: Turtle.FilePath,
    repoPullUrl :: Text
} deriving (Show)

instance FromJSON Repo where
    parseJSON (Object v) = Repo <$> v .: "id" <*> fmap (getPath . pack . idScientific :: Scientific -> Turtle.FilePath) (v .: "id") <*> v .: "clone_url"
    parseJSON _ = Control.Applicative.empty

githubApiReq :: String -> String -> IO Request
githubApiReq user section = do
    initReq <- parseRequest $ jsonURL <> user <> "/" <> section
    return initReq {requestHeaders = [("User-Agent", fromString userAgent)]}

getGists :: Response B.ByteString -> [Gist]
getGists response = fromMaybe ([]::[Gist]) gistsResponse
    where gistsResponse = decode $ responseBody response

getRepos :: Response B.ByteString -> [Repo]
getRepos response = fromMaybe ([]::[Repo]) reposResponse
    where reposResponse = decode $ responseBody response

getPath :: Text -> Turtle.FilePath
getPath = fromString . unpack

getPaths :: [Gist] -> [Turtle.FilePath]
getPaths = fmap (fromString . unpack . gistId)

getReposPaths :: [Repo] -> [Turtle.FilePath]
getReposPaths = fmap (fromString . repoIdFormat)

idScientific :: Scientific -> String
idScientific = formatScientific Fixed (Just 0)

repoIdFormat :: Repo -> String
repoIdFormat repo = idScientific $ repoId repo

cloneGists :: [Gist] -> [IO ExitCode]
cloneGists = fmap (\gist -> shell (pack "git clone --mirror " <> gitPullUrl gist  <> " " <> gistId gist) Control.Applicative.empty)

cloneRepos :: [Repo] -> [IO ExitCode]
cloneRepos = fmap (\repo -> shell (pack "git clone --mirror " <> repoPullUrl repo <> " " <> pack (repoIdFormat repo)) Control.Applicative.empty)

pull :: [Turtle.FilePath] ->[IO ExitCode]
pull = fmap (\file -> shell (pack "git --git-dir " <> format fp file <> pack " fetch --all") Control.Applicative.empty)

createAndCd :: Turtle.FilePath -> IO ()
createAndCd dir = do
    _ <- shell (pack "mkdir -p " <> format fp dir) Control.Applicative.empty
    cd dir

main :: IO ()
main = do
    (user, userDir) <- options "github backup script" optsParser
    let backupDir = fromMaybe defaultDir userDir
    createAndCd backupDir
    echo "saving gists..."
    manager <- liftIO $ newManager tlsManagerSettings
    gistsRequest <- githubApiReq (unpack user) "gists"
    gistsJsonResponse <- liftIO $ httpLbs gistsRequest manager
    let gistsResponse = getGists gistsJsonResponse
    let gistsFilePaths = getPaths gistsResponse
    B.writeFile "gists.json" $ responseBody gistsJsonResponse

    createAndCd gistsDir
    dirList <- fold (ls ".") Fold.list
    let nameList = fmap filename dirList
    let updateList = nameList `intersect` gistsFilePaths
    let clonePaths = gistsFilePaths \\ nameList
    let cloneGistsList = Prelude.filter (\gist -> idPath gist `elem` clonePaths ) gistsResponse
    sequence_ $ cloneGists cloneGistsList
    sequence_ $ pull updateList
    cd ".."
    echo "gists backup finished"

    echo "repos backup starting..."
    reposManager <- liftIO $ newManager tlsManagerSettings
    reposRequest <- githubApiReq (unpack user) "repos"
    reposJsonResponse <- liftIO $ httpLbs reposRequest reposManager
    let reposResponse = getRepos reposJsonResponse
    let reposFilePaths = getReposPaths reposResponse
    B.writeFile "repos.json" $ responseBody reposJsonResponse

    createAndCd reposDir
    reposDirList <- fold (ls ".") Fold.list
    let reposNameList = fmap filename reposDirList
    let reposUpdateList = reposNameList `intersect` reposFilePaths
    let reposClonePaths = reposFilePaths \\ reposNameList

    let cloneReposList = Prelude.filter (\repo -> repoPath repo `elem` reposClonePaths ) reposResponse
    sequence_ $ cloneRepos cloneReposList
    sequence_ $ pull reposUpdateList
    cd ".."
    echo "repos backup finished"