Skip to content

Commit 40045a4

Browse files
pbrisbinpbrisbin
committed
Fully RIO 🎉
1 parent 2a7fe7a commit 40045a4

16 files changed

+421
-286
lines changed

Diff for: ‎src/Restyler/App/Class.hs

+45-113
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,24 @@
11
{-# LANGUAGE FlexibleContexts #-}
22
{-# LANGUAGE FlexibleInstances #-}
33
{-# LANGUAGE GADTs #-}
4-
{-# LANGUAGE OverloadedStrings #-}
54

65
module Restyler.App.Class
7-
( MonadApp(..)
6+
(
7+
-- * Data
8+
HasOptions(..)
9+
, HasConfig(..)
10+
, HasPullRequest(..)
11+
, HasRestyledPullRequest(..)
12+
, HasWorkingDirectory(..)
13+
14+
-- * Capabilities
15+
, HasSystem(..)
16+
, HasExit(..)
17+
, HasProcess(..)
18+
, HasDownloadFile(..)
19+
, HasGitHub(..)
20+
, runGitHubFirst
21+
, runGitHub_
822

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

2236
import Restyler.Prelude
2337

24-
import Conduit (runResourceT, sinkFile)
2538
import GitHub.Endpoints.Issues.Comments hiding (comment, comments)
2639
import GitHub.Endpoints.Issues.Labels
2740
import GitHub.Endpoints.PullRequests hiding (pullRequest)
2841
import GitHub.Endpoints.PullRequests.ReviewRequests
2942
import GitHub.Endpoints.Repos.Statuses
30-
import GitHub.Request
31-
import Network.HTTP.Client.TLS
32-
import Network.HTTP.Simple hiding (Request)
33-
import Restyler.App.Type
34-
import qualified RIO.Directory as Directory
35-
import qualified RIO.Text as T
43+
import Restyler.Config
44+
import Restyler.Options
45+
import Restyler.PullRequest
3646
import qualified RIO.Vector as V
37-
import qualified System.Exit as Exit
38-
import qualified System.Process as Process
3947

40-
class
41-
( Monad m
42-
, MonadLogger m
43-
, MonadReader App m
44-
, MonadError AppError m
45-
)
46-
=> MonadApp m where
47-
runGitHub :: Request k a -> m a
48+
class HasWorkingDirectory env where
49+
workingDirectoryL :: Lens' env FilePath
4850

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

53-
-- | @'void' . 'runGitHub'@
54-
runGitHub_ :: Request k a -> m ()
55-
runGitHub_ = void . runGitHub
57+
class HasExit env where
58+
exitSuccess :: RIO env ()
5659

57-
getCurrentDirectory :: m FilePath
58-
setCurrentDirectory :: FilePath -> m ()
60+
class HasProcess env where
61+
callProcess :: String -> [String] -> RIO env ()
62+
readProcess :: String -> [String] -> String -> RIO env String
5963

60-
doesFileExist :: FilePath -> m Bool
61-
readFile :: FilePath -> m Text
64+
-- class HasProcess env => HasGit env where
6265

63-
exitSuccess :: m ()
66+
class HasDownloadFile env where
67+
downloadFile :: Text -> FilePath -> RIO env ()
6468

65-
callProcess :: String -> [String] -> m ()
66-
readProcess :: String -> [String] -> String -> m String
69+
class HasGitHub env where
70+
runGitHub :: Request k a -> RIO env a
6771

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

70-
instance MonadIO m => MonadApp (AppT m) where
71-
runGitHub req = do
72-
logDebugN $ "GitHub request: " <> showGitHubRequest req
73-
auth <- asks $ OAuth . encodeUtf8 . appAccessToken
74-
result <- appIO OtherError $ do
75-
mgr <- getGlobalManager
76-
executeRequestWithMgr mgr auth req
77-
either (throwError . GitHubError) pure result
78-
79-
getCurrentDirectory = do
80-
logDebugN "getCurrentDirectory"
81-
appIO SystemError Directory.getCurrentDirectory
82-
83-
setCurrentDirectory path = do
84-
logDebugN $ "setCurrentDirectory: " <> tshow path
85-
appIO SystemError $ Directory.setCurrentDirectory path
86-
87-
doesFileExist path = do
88-
logDebugN $ "doesFileExist: " <> tshow path
89-
appIO SystemError $ Directory.doesFileExist path
90-
91-
readFile path = do
92-
logDebugN $ "readFile: " <> tshow path
93-
appIO SystemError $ readFileUtf8 path
94-
95-
exitSuccess = do
96-
logDebugN "exitSuccess"
97-
appIO SystemError Exit.exitSuccess
98-
99-
callProcess cmd args = do
100-
-- N.B. this includes access tokens in log messages when used for
101-
-- git-clone. That's acceptable because:
102-
--
103-
-- - These tokens are ephemeral (5 minutes)
104-
-- - We generally accept secrets in DEBUG messages
105-
--
106-
logDebugN $ pack $ "call: " <> cmd <> " " <> show args
107-
appIO SystemError $ Process.callProcess cmd args
108-
109-
readProcess cmd args stdin' = do
110-
logDebugN $ pack $ "read: " <> cmd <> " " <> show args
111-
output <- appIO SystemError $ Process.readProcess cmd args stdin'
112-
output <$ logDebugN ("output: " <> pack output)
113-
114-
downloadFile url path = do
115-
logDebugN $ "HTTP GET: " <> tshow url <> " => " <> tshow path
116-
appIO HttpError $ do
117-
request <- parseRequest $ unpack url
118-
runResourceT $ httpSink request $ \_ -> sinkFile path
119-
120-
-- | Run an @'IO'@ computation and capture @'IOException'@s to the given type
121-
appIO :: MonadIO m => (IOException -> AppError) -> IO a -> AppT m a
122-
appIO err f = AppT $ do
123-
result <- liftIO $ tryIO f
124-
either (throwError . err) pure result
125-
126-
-- | Show a GitHub @'Request'@, useful for debugging
127-
-- brittany-disable-next-binding
128-
showGitHubRequest :: Request k a -> Text
129-
showGitHubRequest (SimpleQuery (Query ps qs)) = mconcat
130-
[ "[GET] "
131-
, "/" <> T.intercalate "/" ps
132-
, "?" <> T.intercalate "&" (queryParts qs)
133-
]
134-
showGitHubRequest (SimpleQuery (PagedQuery ps qs fc)) = mconcat
135-
[ "[GET] "
136-
, "/" <> T.intercalate "/" ps
137-
, "?" <> T.intercalate "&" (queryParts qs)
138-
, " (" <> tshow fc <> ")"
139-
]
140-
showGitHubRequest (SimpleQuery (Command m ps _body)) = mconcat
141-
[ "[" <> T.toUpper (tshow m) <> "] "
142-
, "/" <> T.intercalate "/" ps
143-
]
144-
showGitHubRequest (StatusQuery _ _) = "<status query>"
145-
showGitHubRequest (HeaderQuery _ _) = "<header query>"
146-
showGitHubRequest (RedirectQuery _) = "<redirect query>"
147-
148-
queryParts :: QueryString -> [Text]
149-
queryParts = map $ \(k, mv) -> decodeUtf8 k <> "=" <> maybe "" decodeUtf8 mv
79+
-- | @'void' . 'runGitHub'@
80+
runGitHub_ :: HasGitHub env => Request k a -> RIO env ()
81+
runGitHub_ = void . runGitHub

Diff for: ‎src/Restyler/App/Type.hs

+126-19
Original file line numberDiff line numberDiff line change
@@ -1,23 +1,27 @@
11
{-# LANGUAGE FlexibleContexts #-}
2-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
32

43
module Restyler.App.Type
54
( App(..)
65

76
-- * Application errors
87
, AppError(..)
98
, mapAppError
10-
11-
-- * Concrete Application stack
12-
, AppT(..)
139
) where
1410

1511
import Restyler.Prelude
1612

17-
import Control.Monad.Logger (LoggingT)
13+
import Conduit (runResourceT, sinkFile)
1814
import qualified Data.Yaml as Yaml
15+
import GitHub.Request
16+
import Network.HTTP.Client.TLS
17+
import Network.HTTP.Simple hiding (Request)
18+
import Restyler.App.Class
1919
import Restyler.Config
2020
import Restyler.Options
21+
import qualified RIO.Directory as Directory
22+
import qualified RIO.Text as T
23+
import qualified System.Exit as Exit
24+
import qualified System.Process as Process
2125

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

43+
instance HasLogFunc App where
44+
logFuncL = undefined
45+
46+
instance HasOptions App where
47+
optionsL = lens appOptions $ \x y -> x { appOptions = y }
48+
49+
instance HasWorkingDirectory App where
50+
workingDirectoryL = lens appWorkingDirectory $ \x y ->
51+
x { appWorkingDirectory = y }
52+
53+
instance HasConfig App where
54+
configL = lens appConfig $ \x y -> x { appConfig = y }
55+
56+
instance HasPullRequest App where
57+
pullRequestL = lens appPullRequest $ \x y -> x { appPullRequest = y }
58+
59+
instance HasRestyledPullRequest App where
60+
restyledPullRequestL = lens appRestyledPullRequest $ \x y ->
61+
x { appRestyledPullRequest = y }
62+
3963
-- | All possible application error conditions
4064
data AppError
4165
= PullRequestFetchError Error
@@ -56,18 +80,101 @@ data AppError
5680
-- ^ A minor escape hatch for @'IOException'@s
5781
deriving Show
5882

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

63-
newtype AppT m a = AppT
64-
{ runAppT :: ReaderT App (LoggingT (ExceptT AppError m)) a
65-
}
66-
deriving
67-
( Functor
68-
, Applicative
69-
, Monad
70-
, MonadError AppError
71-
, MonadReader App
72-
, MonadLogger
73-
)
85+
-- | Run a computation, and modify any thrown exceptions to @'AppError'@s
86+
mapAppError
87+
:: (MonadUnliftIO m, Exception e)
88+
=> (e -> AppError) -> m a -> m a
89+
mapAppError f = (`catch` throwIO . f)
90+
91+
-- | Run an @'IO'@ computation and capture @'IOException'@s to the given type
92+
appIO :: MonadUnliftIO m => (IOException -> AppError) -> IO a -> m a
93+
appIO f = mapAppError f . liftIO
94+
95+
instance HasSystem App where
96+
getCurrentDirectory = do
97+
logDebug "getCurrentDirectory"
98+
appIO SystemError Directory.getCurrentDirectory
99+
100+
setCurrentDirectory path = do
101+
logDebug $ "setCurrentDirectory: " <> displayShow path
102+
appIO SystemError $ Directory.setCurrentDirectory path
103+
104+
doesFileExist path = do
105+
logDebug $ "doesFileExist: " <> displayShow path
106+
appIO SystemError $ Directory.doesFileExist path
107+
108+
readFile path = do
109+
logDebug $ "readFile: " <> displayShow path
110+
appIO SystemError $ readFileUtf8 path
111+
112+
instance HasExit App where
113+
exitSuccess = do
114+
logDebug "exitSuccess"
115+
appIO SystemError Exit.exitSuccess
116+
117+
instance HasProcess App where
118+
callProcess cmd args = do
119+
-- N.B. this includes access tokens in log messages when used for
120+
-- git-clone. That's acceptable because:
121+
--
122+
-- - These tokens are ephemeral (5 minutes)
123+
-- - We generally accept secrets in DEBUG messages
124+
--
125+
logDebug $ "call: " <> fromString cmd <> " " <> displayShow args
126+
appIO SystemError $ Process.callProcess cmd args
127+
128+
readProcess cmd args stdin' = do
129+
logDebug $ "read: " <> fromString cmd <> " " <> displayShow args
130+
output <- appIO SystemError $ Process.readProcess cmd args stdin'
131+
output <$ logDebug ("output: " <> fromString output)
132+
133+
instance HasDownloadFile App where
134+
downloadFile url path = do
135+
logDebug $ "HTTP GET: " <> displayShow url <> " => " <> displayShow path
136+
appIO HttpError $ do
137+
request <- parseRequest $ unpack url
138+
runResourceT $ httpSink request $ \_ -> sinkFile path
139+
140+
instance HasGitHub App where
141+
runGitHub req = do
142+
logDebug $ "GitHub request: " <> showGitHubRequest req
143+
auth <- asks $ OAuth . encodeUtf8 . appAccessToken
144+
result <- appIO OtherError $ do
145+
mgr <- getGlobalManager
146+
executeRequestWithMgr mgr auth req
147+
either (throwIO . GitHubError) pure result
148+
149+
-- brittany-disable-next-binding
150+
151+
-- | Show a GitHub @'Request'@, useful for debugging
152+
--
153+
-- TODO: Use a newtype and @'displayShow'@
154+
--
155+
showGitHubRequest :: Request k a -> Utf8Builder
156+
showGitHubRequest = fromString . unpack . format
157+
where
158+
format :: Request k a -> Text
159+
format = \case
160+
SimpleQuery (Query ps qs) -> mconcat
161+
[ "[GET] "
162+
, "/" <> T.intercalate "/" ps
163+
, "?" <> T.intercalate "&" (queryParts qs)
164+
]
165+
SimpleQuery (PagedQuery ps qs fc) -> mconcat
166+
[ "[GET] "
167+
, "/" <> T.intercalate "/" ps
168+
, "?" <> T.intercalate "&" (queryParts qs)
169+
, " (" <> tshow fc <> ")"
170+
]
171+
SimpleQuery (Command m ps _body) -> mconcat
172+
[ "[" <> T.toUpper (tshow m) <> "] "
173+
, "/" <> T.intercalate "/" ps
174+
]
175+
StatusQuery _ _ -> "<status query>"
176+
HeaderQuery _ _ -> "<header query>"
177+
RedirectQuery _ -> "<redirect query>"
178+
179+
queryParts :: QueryString -> [Text]
180+
queryParts = map $ \(k, mv) -> decodeUtf8 k <> "=" <> maybe "" decodeUtf8 mv

0 commit comments

Comments
 (0)