Skip to content
Permalink
Browse files

Fully RIO 🎉

  • Loading branch information...
pbrisbin committed Apr 11, 2019
1 parent 2a7fe7a commit 40045a4f7d89f999c214484f89cc47f781412c3c
@@ -1,10 +1,24 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}

module Restyler.App.Class
( MonadApp(..)
(
-- * Data
HasOptions(..)
, HasConfig(..)
, HasPullRequest(..)
, HasRestyledPullRequest(..)
, HasWorkingDirectory(..)

-- * Capabilities
, HasSystem(..)
, HasExit(..)
, HasProcess(..)
, HasDownloadFile(..)
, HasGitHub(..)
, runGitHubFirst
, runGitHub_

-- * Re-exports
-- |
@@ -21,129 +35,47 @@ module Restyler.App.Class

import Restyler.Prelude

import Conduit (runResourceT, sinkFile)
import GitHub.Endpoints.Issues.Comments hiding (comment, comments)
import GitHub.Endpoints.Issues.Labels
import GitHub.Endpoints.PullRequests hiding (pullRequest)
import GitHub.Endpoints.PullRequests.ReviewRequests
import GitHub.Endpoints.Repos.Statuses
import GitHub.Request
import Network.HTTP.Client.TLS
import Network.HTTP.Simple hiding (Request)
import Restyler.App.Type
import qualified RIO.Directory as Directory
import qualified RIO.Text as T
import Restyler.Config
import Restyler.Options
import Restyler.PullRequest
import qualified RIO.Vector as V
import qualified System.Exit as Exit
import qualified System.Process as Process

class
( Monad m
, MonadLogger m
, MonadReader App m
, MonadError AppError m
)
=> MonadApp m where
runGitHub :: Request k a -> m a
class HasWorkingDirectory env where
workingDirectoryL :: Lens' env FilePath

-- | Fetch the first page using @'runGitHub'@, return the first item
runGitHubFirst :: (FetchCount -> Request k (Vector a)) -> m (Maybe a)
runGitHubFirst f = (V.!? 0) <$> runGitHub (f 1)
class HasSystem env where
getCurrentDirectory :: RIO env FilePath
setCurrentDirectory :: FilePath -> RIO env ()
doesFileExist :: FilePath -> RIO env Bool
readFile :: FilePath -> RIO env Text

-- | @'void' . 'runGitHub'@
runGitHub_ :: Request k a -> m ()
runGitHub_ = void . runGitHub
class HasExit env where
exitSuccess :: RIO env ()

getCurrentDirectory :: m FilePath
setCurrentDirectory :: FilePath -> m ()
class HasProcess env where
callProcess :: String -> [String] -> RIO env ()
readProcess :: String -> [String] -> String -> RIO env String

doesFileExist :: FilePath -> m Bool
readFile :: FilePath -> m Text
-- class HasProcess env => HasGit env where

exitSuccess :: m ()
class HasDownloadFile env where
downloadFile :: Text -> FilePath -> RIO env ()

callProcess :: String -> [String] -> m ()
readProcess :: String -> [String] -> String -> m String
class HasGitHub env where
runGitHub :: Request k a -> RIO env a

downloadFile :: Text -> FilePath -> m ()
-- | Fetch the first page using @'runGitHub'@, return the first item
runGitHubFirst
:: HasGitHub env
=> (FetchCount -> Request k (Vector a))
-> RIO env (Maybe a)
runGitHubFirst f = (V.!? 0) <$> runGitHub (f 1)

instance MonadIO m => MonadApp (AppT m) where
runGitHub req = do
logDebugN $ "GitHub request: " <> showGitHubRequest req
auth <- asks $ OAuth . encodeUtf8 . appAccessToken
result <- appIO OtherError $ do
mgr <- getGlobalManager
executeRequestWithMgr mgr auth req
either (throwError . GitHubError) pure result

getCurrentDirectory = do
logDebugN "getCurrentDirectory"
appIO SystemError Directory.getCurrentDirectory

setCurrentDirectory path = do
logDebugN $ "setCurrentDirectory: " <> tshow path
appIO SystemError $ Directory.setCurrentDirectory path

doesFileExist path = do
logDebugN $ "doesFileExist: " <> tshow path
appIO SystemError $ Directory.doesFileExist path

readFile path = do
logDebugN $ "readFile: " <> tshow path
appIO SystemError $ readFileUtf8 path

exitSuccess = do
logDebugN "exitSuccess"
appIO SystemError Exit.exitSuccess

callProcess cmd args = do
-- N.B. this includes access tokens in log messages when used for
-- git-clone. That's acceptable because:
--
-- - These tokens are ephemeral (5 minutes)
-- - We generally accept secrets in DEBUG messages
--
logDebugN $ pack $ "call: " <> cmd <> " " <> show args
appIO SystemError $ Process.callProcess cmd args

readProcess cmd args stdin' = do
logDebugN $ pack $ "read: " <> cmd <> " " <> show args
output <- appIO SystemError $ Process.readProcess cmd args stdin'
output <$ logDebugN ("output: " <> pack output)

downloadFile url path = do
logDebugN $ "HTTP GET: " <> tshow url <> " => " <> tshow path
appIO HttpError $ do
request <- parseRequest $ unpack url
runResourceT $ httpSink request $ \_ -> sinkFile path

-- | Run an @'IO'@ computation and capture @'IOException'@s to the given type
appIO :: MonadIO m => (IOException -> AppError) -> IO a -> AppT m a
appIO err f = AppT $ do
result <- liftIO $ tryIO f
either (throwError . err) pure result

-- | Show a GitHub @'Request'@, useful for debugging
-- brittany-disable-next-binding
showGitHubRequest :: Request k a -> Text
showGitHubRequest (SimpleQuery (Query ps qs)) = mconcat
[ "[GET] "
, "/" <> T.intercalate "/" ps
, "?" <> T.intercalate "&" (queryParts qs)
]
showGitHubRequest (SimpleQuery (PagedQuery ps qs fc)) = mconcat
[ "[GET] "
, "/" <> T.intercalate "/" ps
, "?" <> T.intercalate "&" (queryParts qs)
, " (" <> tshow fc <> ")"
]
showGitHubRequest (SimpleQuery (Command m ps _body)) = mconcat
[ "[" <> T.toUpper (tshow m) <> "] "
, "/" <> T.intercalate "/" ps
]
showGitHubRequest (StatusQuery _ _) = "<status query>"
showGitHubRequest (HeaderQuery _ _) = "<header query>"
showGitHubRequest (RedirectQuery _) = "<redirect query>"

queryParts :: QueryString -> [Text]
queryParts = map $ \(k, mv) -> decodeUtf8 k <> "=" <> maybe "" decodeUtf8 mv
-- | @'void' . 'runGitHub'@
runGitHub_ :: HasGitHub env => Request k a -> RIO env ()
runGitHub_ = void . runGitHub
@@ -1,23 +1,27 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Restyler.App.Type
( App(..)

-- * Application errors
, AppError(..)
, mapAppError

-- * Concrete Application stack
, AppT(..)
) where

import Restyler.Prelude

import Control.Monad.Logger (LoggingT)
import Conduit (runResourceT, sinkFile)
import qualified Data.Yaml as Yaml
import GitHub.Request
import Network.HTTP.Client.TLS
import Network.HTTP.Simple hiding (Request)
import Restyler.App.Class
import Restyler.Config
import Restyler.Options
import qualified RIO.Directory as Directory
import qualified RIO.Text as T
import qualified System.Exit as Exit
import qualified System.Process as Process

-- | Application environment
data App = App
@@ -36,6 +40,26 @@ data App = App
-- ^ Temporary directory we are working in
}

instance HasLogFunc App where
logFuncL = undefined

instance HasOptions App where
optionsL = lens appOptions $ \x y -> x { appOptions = y }

instance HasWorkingDirectory App where
workingDirectoryL = lens appWorkingDirectory $ \x y ->
x { appWorkingDirectory = y }

instance HasConfig App where
configL = lens appConfig $ \x y -> x { appConfig = y }

instance HasPullRequest App where
pullRequestL = lens appPullRequest $ \x y -> x { appPullRequest = y }

instance HasRestyledPullRequest App where
restyledPullRequestL = lens appRestyledPullRequest $ \x y ->
x { appRestyledPullRequest = y }

-- | All possible application error conditions
data AppError
= PullRequestFetchError Error
@@ -56,18 +80,101 @@ data AppError
-- ^ A minor escape hatch for @'IOException'@s
deriving Show

-- | Run a computation, and modify any thrown @'AppError'@s
mapAppError :: MonadError AppError m => (AppError -> AppError) -> m a -> m a
mapAppError f = (`catchError` throwError . f)
instance Exception AppError

newtype AppT m a = AppT
{ runAppT :: ReaderT App (LoggingT (ExceptT AppError m)) a
}
deriving
( Functor
, Applicative
, Monad
, MonadError AppError
, MonadReader App
, MonadLogger
)
-- | Run a computation, and modify any thrown exceptions to @'AppError'@s
mapAppError
:: (MonadUnliftIO m, Exception e)
=> (e -> AppError) -> m a -> m a
mapAppError f = (`catch` throwIO . f)

-- | Run an @'IO'@ computation and capture @'IOException'@s to the given type
appIO :: MonadUnliftIO m => (IOException -> AppError) -> IO a -> m a
appIO f = mapAppError f . liftIO

instance HasSystem App where
getCurrentDirectory = do
logDebug "getCurrentDirectory"
appIO SystemError Directory.getCurrentDirectory

setCurrentDirectory path = do
logDebug $ "setCurrentDirectory: " <> displayShow path
appIO SystemError $ Directory.setCurrentDirectory path

doesFileExist path = do
logDebug $ "doesFileExist: " <> displayShow path
appIO SystemError $ Directory.doesFileExist path

readFile path = do
logDebug $ "readFile: " <> displayShow path
appIO SystemError $ readFileUtf8 path

instance HasExit App where
exitSuccess = do
logDebug "exitSuccess"
appIO SystemError Exit.exitSuccess

instance HasProcess App where
callProcess cmd args = do
-- N.B. this includes access tokens in log messages when used for
-- git-clone. That's acceptable because:
--
-- - These tokens are ephemeral (5 minutes)
-- - We generally accept secrets in DEBUG messages
--
logDebug $ "call: " <> fromString cmd <> " " <> displayShow args
appIO SystemError $ Process.callProcess cmd args

readProcess cmd args stdin' = do
logDebug $ "read: " <> fromString cmd <> " " <> displayShow args
output <- appIO SystemError $ Process.readProcess cmd args stdin'
output <$ logDebug ("output: " <> fromString output)

instance HasDownloadFile App where
downloadFile url path = do
logDebug $ "HTTP GET: " <> displayShow url <> " => " <> displayShow path
appIO HttpError $ do
request <- parseRequest $ unpack url
runResourceT $ httpSink request $ \_ -> sinkFile path

instance HasGitHub App where
runGitHub req = do
logDebug $ "GitHub request: " <> showGitHubRequest req
auth <- asks $ OAuth . encodeUtf8 . appAccessToken
result <- appIO OtherError $ do
mgr <- getGlobalManager
executeRequestWithMgr mgr auth req
either (throwIO . GitHubError) pure result

-- brittany-disable-next-binding

-- | Show a GitHub @'Request'@, useful for debugging
--
-- TODO: Use a newtype and @'displayShow'@
--
showGitHubRequest :: Request k a -> Utf8Builder
showGitHubRequest = fromString . unpack . format
where
format :: Request k a -> Text
format = \case
SimpleQuery (Query ps qs) -> mconcat
[ "[GET] "
, "/" <> T.intercalate "/" ps
, "?" <> T.intercalate "&" (queryParts qs)
]
SimpleQuery (PagedQuery ps qs fc) -> mconcat
[ "[GET] "
, "/" <> T.intercalate "/" ps
, "?" <> T.intercalate "&" (queryParts qs)
, " (" <> tshow fc <> ")"
]
SimpleQuery (Command m ps _body) -> mconcat
[ "[" <> T.toUpper (tshow m) <> "] "
, "/" <> T.intercalate "/" ps
]
StatusQuery _ _ -> "<status query>"
HeaderQuery _ _ -> "<header query>"
RedirectQuery _ -> "<redirect query>"

queryParts :: QueryString -> [Text]
queryParts = map $ \(k, mv) -> decodeUtf8 k <> "=" <> maybe "" decodeUtf8 mv
Oops, something went wrong.

0 comments on commit 40045a4

Please sign in to comment.
You can’t perform that action at this time.