{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Main
( main
) where
import Control.Monad.IO.Class ( liftIO )
import Data.Aeson ( Object )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import Network.Wai ( Application )
import Network.Wai.Handler.Warp ( run )
import Servant
import Servant.GitHub.Webhook
-- | Entry point for travis.
-- We don't actually have automated tests, so we use a dummy main for travis,
-- so that /running/ the tests passes, but compiling may not.
main :: IO ()
main = pure ()
realMain :: IO ()
realMain = do
[k1, k2] <- C8.lines <$> BS.readFile "test/test-keys"
run 8080 (app (constKeys k1 k2))
app :: MyGitHubKey -> Application
app k = serveWithContext api (k :. EmptyContext) server
server :: Server WebhookApi
server = (repo1ping :<|> repo1any) :<|> repo2any
repo1ping :: RepoWebhookEvent -> (Key, Object) -> Handler ()
repo1ping _ _ = liftIO $ putStrLn "got ping on repo1!"
repo1any :: RepoWebhookEvent -> (Key, Object) -> Handler ()
repo1any e _ = liftIO $ putStrLn $ "got event on repo 1: " ++ show e
repo2any :: RepoWebhookEvent -> (Key, Object) -> Handler ()
repo2any e _ = liftIO $ putStrLn $ "got event on repo 2: " ++ show e
api :: Proxy WebhookApi
api = Proxy
type WebhookApi
= "repo1" :> (
GitHubEvent '[ 'WebhookPingEvent ]
:> GitHubSignedReqBody' 'Repo1 '[JSON] Object
:> Post '[JSON] ()
:<|>
GitHubEvent '[ 'WebhookWildcardEvent ]
:> GitHubSignedReqBody' 'Repo1 '[JSON] Object
:> Post '[JSON] ()
)
:<|>
"repo2"
:> GitHubEvent '[ 'WebhookWildcardEvent ]
:> GitHubSignedReqBody' 'Repo2 '[JSON] Object
:> Post '[JSON] ()
type MyGitHubKey = GitHubKey' Key Object
data Key
= Repo1
| Repo2
constKeys :: BS.ByteString -> BS.ByteString -> MyGitHubKey
constKeys k1 k2 = GitHubKey $ \k _ -> pure $ case k of
Repo1 -> Just k1
Repo2 -> Just k2
type instance Demote' ('KProxy :: KProxy Key) = Key
instance Reflect 'Repo1 where
reflect _ = Repo1
instance Reflect 'Repo2 where
reflect _ = Repo2