Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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...)
#!/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"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.