-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
1 parent
dfc3d92
commit 2f7f8cc
Showing
1 changed file
with
93 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,93 @@ | ||
#!/usr/bin/env cabal | ||
{- cabal: | ||
build-depends: | ||
base | ||
, bytestring | ||
, aeson | ||
, github >= 0.28 | ||
, optparse-applicative | ||
, relude | ||
, safe-exceptions | ||
, pretty-simple | ||
, text | ||
, yaml | ||
, xdg-basedir | ||
default-extensions: | ||
NoImplicitPrelude | ||
, GADTs | ||
, DerivingStrategies | ||
, DeriveAnyClass | ||
, GeneralizedNewtypeDeriving | ||
, StandaloneDeriving | ||
, ScopedTypeVariables | ||
, FlexibleContexts | ||
, LambdaCase | ||
, OverloadedStrings | ||
, RecordWildCards | ||
, OverloadedLists | ||
ghc-options: -Wall -Wextra -Wcompat | ||
-} | ||
|
||
import Control.Exception.Safe | ||
import Data.Aeson ((.:)) | ||
import qualified Data.Yaml as Y | ||
import GHC.Stack | ||
import qualified GitHub.Auth as G | ||
import qualified Relude | ||
import Relude hiding (error, liftIO) | ||
import qualified System.Environment.XDG.BaseDir as XDG | ||
import Text.Pretty.Simple | ||
import System.IO (hPutStrLn, stderr) | ||
|
||
main :: IO () | ||
main = handleExceptions $ do | ||
putStrLn $ "hello cabal" | ||
res <- getAuthToken | ||
print res | ||
where | ||
handleExceptions m = catch m $ \someExc@SomeException{} -> do | ||
hPutStrLn stderr $ "\nCaught exception:\n" <> displayException someExc | ||
|
||
|
||
getAuthToken :: (HasCallStack, MonadCatch m, MonadIO m) => m G.Auth | ||
getAuthToken = handle (throwM . AuthTokenException) $ do | ||
-- error (show . AppException . toException $ StringException "asdf" callStack) | ||
token <- lookupEnv "DOR_GH_TOKEN" >>= \case | ||
Just token -> pure $ toText token | ||
Nothing -> | ||
runIO (XDG.getUserConfigFile "gh" "xhosts.yml") | ||
>>= (runIO . Y.decodeFileThrow) | ||
>>= parseThrow ((.: "github.com") >=> (.: "oauth_token")) | ||
pure . G.OAuth $ encodeUtf8 token | ||
where | ||
parseThrow :: (HasCallStack, MonadIO m) => (a -> Y.Parser b) -> a -> m b | ||
parseThrow p v = withFrozenCallStack $ | ||
either (error . toText) pure $ | ||
Y.parseEither p v | ||
|
||
data AuthTokenException = HasCallStack => AuthTokenException SomeException | ||
deriving instance Show AuthTokenException | ||
deriving instance Typeable AuthTokenException | ||
instance Exception AuthTokenException where | ||
displayException (AuthTokenException e) = "Cannot obtain GitHub authentication token:\n" <> displayException e | ||
|
||
-- {{{ Infrastructure | ||
|
||
data AppException = HasCallStack => AppException SomeException | ||
deriving instance Show AppException | ||
deriving instance Typeable AppException | ||
instance Exception AppException where | ||
displayException (AppException ex) = displayException ex <> "\n" <> prettyCallStack callStack | ||
|
||
runIO :: (HasCallStack, MonadCatch m, MonadIO m) => IO a -> m a | ||
runIO m = withFrozenCallStack $ catch (Relude.liftIO m) $ (throwM . AppException) | ||
|
||
rethrowWith :: (HasCallStack, MonadThrow m, MonadIO m, Exception e1, Exception e2) => (e -> SomeException) -> m a -> m a | ||
rethrowWith f m = withFrozenCallStack $ catch m $ (throwM . f) | ||
|
||
error :: (HasCallStack, MonadIO m) => Text -> m a | ||
error a = withFrozenCallStack $ Relude.error a | ||
|
||
-- }}} | ||
|
||
-- vim: set filetype=haskell: |