Task.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE OverloadedStrings #-}
module Task
  ( Task
  , run
  , Transaction
  , bail
  , attempt
  , fetchGithub
  )
  where


import Control.Exception (SomeException, catch, try)
import Control.Monad.Except (ExceptT, runExceptT, throwError)
import Control.Monad.Reader (ReaderT, runReaderT, ask)
import Control.Monad.Trans (liftIO)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as Text
import qualified System.Directory as Dir
import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.IO (hPutStrLn, stderr)

import qualified Elm.Package as Pkg
import qualified Http
import qualified Json.Decode as Decode



-- TASKS


type Task =
  ExceptT String (ReaderT Http.Token IO)


run :: String -> Task a -> IO ()
run githubToken task =
  do  token <- Http.init githubToken
      result <- runReaderT (runExceptT task) token
      case result of
        Right _ ->
          putStrLn "Success!"

        Left msg ->
          do  hPutStrLn stderr msg
              exitFailure



-- ERROR


type Transaction =
  ExceptT Error (ReaderT Http.Token IO)


newtype Error = Error String


bail :: String -> Transaction a
bail msg =
  throwError (Error msg)


attempt :: Pkg.Name -> Pkg.Version -> Transaction a -> Task a
attempt pkg vsn transaction =
  do  token <- ask

      result <- liftIO $ runReaderT (runExceptT transaction) token
        `catch` \e -> return (Left (Error (show (e :: SomeException))))

      case result of
        Right a ->
          return a

        Left (Error msg) ->
          do  liftIO $ hPutStrLn stderr $
                "Bailed out of " ++ Pkg.toString pkg ++ " " ++ Pkg.versionToString vsn ++ " transaction."
              liftIO $ removeDirectory pkg vsn
              throwError msg


removeDirectory :: Pkg.Name -> Pkg.Version -> IO ()
removeDirectory (Pkg.Name user project) version =
  do  let usr = Text.unpack user
      let prj = Text.unpack project
      let vsn = Pkg.versionToString version

      Dir.removeDirectoryRecursive ("packages" </> usr </> prj </> vsn)
      _ <- try $ Dir.removeDirectory ("packages" </> usr </> prj) :: IO (Either SomeException ())
      _ <- try $ Dir.removeDirectory ("packages" </> usr) :: IO (Either SomeException ())

      return ()



-- HTTP


fetchGithub :: Decode.Decoder e a -> String -> Task a
fetchGithub decoder path =
  do  token <- ask
      result <- liftIO $ Http.fetchGithub token path
      case result of
        Left msg ->
          throwError msg

        Right bytestring ->
          case Decode.parse "github" (\_ -> []) decoder (LBS.toStrict bytestring) of
            Left _ ->
              throwError ("Bad JSON from GitHub for " ++ path)

            Right value ->
              return value