From 189b57e18b84e294f939ac1f0ea9ca69bcdd9661 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Fri, 8 Jan 2021 20:17:02 -0500 Subject: Add cookies and store user tokens Boy that was harder than I thought, but the code is pretty clean now. I still need to fixup the error handling, and maybe move all the extra args into an app monad, but I think otherwise I have it in a good place. --- Biz/Devalloc.hs | 276 ++++++++++++++++++++++++++++++++++++++++++++----------- Biz/Devalloc.nix | 1 + 2 files changed, 225 insertions(+), 52 deletions(-) diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index a4bfb8d..5e23e67 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -18,8 +18,6 @@ -- : out devalloc -- : dep acid-state -- : dep clay --- dep cmark --- sys cmark -- : dep envy -- : dep github -- : dep ixset @@ -28,6 +26,8 @@ -- : dep req -- : dep safecopy -- : dep servant +-- : dep servant-auth +-- : dep servant-auth-server -- : dep servant-lucid -- : dep servant-server -- : dep uuid @@ -44,6 +44,7 @@ import Biz.App (CSS (..), HtmlApp (..)) import qualified Biz.Look import qualified Clay import qualified Control.Exception as Exception +import Crypto.JOSE.JWK (JWK) import Data.Acid (makeAcidic) import qualified Data.Acid as Acid import qualified Data.Aeson as Aeson @@ -71,7 +72,9 @@ import qualified Network.Wai.Handler.Warp as Warp import Network.Wai.Middleware.RequestLogger (logStdout) import Servant import Servant.API.Generic (ToServantApi, genericApi, toServant, (:-)) -import Servant.HTML.Lucid +import qualified Servant.Auth as Auth +import qualified Servant.Auth.Server as Auth +import qualified Servant.HTML.Lucid as Lucid import Servant.Server.Generic (AsServer) import qualified System.Directory as Directory import qualified System.Envy as Envy @@ -84,22 +87,57 @@ import qualified Web.FormUrlEncoded -- this must go first because of template haskell splicing newtype UserEmail = UserEmail {unUserEmail :: Text} - deriving (Eq, Ord, Data, Typeable) + deriving (Eq, Ord, Data, Typeable, Generic, Show) + +instance Aeson.ToJSON UserEmail + +instance Aeson.FromJSON UserEmail + +instance Auth.ToJWT UserEmail + +instance Auth.FromJWT UserEmail $(deriveSafeCopy 0 'base ''UserEmail) +-- | In 'GitHub.Data.Definitions' this is '(Id User)', but I don't want the +-- extra complexity of 'Id', so just store the underlying Int +newtype GitHubId = GitHubId {unGitHubId :: Int} + deriving (Eq, Ord, Data, Typeable, Generic, Show) + +instance Aeson.ToJSON GitHubId + +instance Aeson.FromJSON GitHubId + +instance Auth.ToJWT GitHubId + +instance Auth.FromJWT GitHubId + +$(deriveSafeCopy 0 'base ''GitHubId) + +-- | The main representation of a user. data User = User { userEmail :: UserEmail, + userGitHubId :: GitHubId, + -- | So we can make GitHub API calls on their behalf. userGitHubToken :: Text } - deriving (Eq, Data, Typeable, Ord) + deriving (Eq, Data, Typeable, Ord, Generic, Show) + +instance Aeson.ToJSON User + +instance Aeson.FromJSON User + +instance Auth.ToJWT User + +instance Auth.FromJWT User $(deriveSafeCopy 0 'base ''User) instance Indexable User where empty = ixSet - [ ixFun <| \u -> [userEmail u] + [ ixFun <| \u -> [userEmail u], + ixFun <| \u -> [userGitHubId u] ] -- | The database. @@ -120,12 +158,36 @@ newUser u = do put <| keep {users = IxSet.insert u (users keep)} return u -getUserByEmail :: Text -> Acid.Query Keep (Maybe User) +updateUser :: User -> Acid.Update Keep User +updateUser u = do + keep <- get + put <| keep {users = IxSet.updateIx (userGitHubId u) u (users keep)} + return u + +getUserByEmail :: UserEmail -> Acid.Query Keep (Maybe User) getUserByEmail email = do Keep {..} <- ask return <| IxSet.getOne <| users @= email -$(makeAcidic ''Keep ['newUser, 'getUserByEmail]) +$(makeAcidic ''Keep ['newUser, 'updateUser, 'getUserByEmail]) + +upsertGitHubUser :: Acid.AcidState Keep -> ByteString -> GitHub.User -> IO User +upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of + -- Nothing -> throwError err502 { errBody = "No user email" } + Nothing -> panic "No user email" + Just email -> + Acid.query keep (GetUserByEmail <| UserEmail email) >>= \case + Just user -> + -- need to refresh the token + Acid.update keep <| UpdateUser user {userGitHubToken = Encoding.decodeUtf8 tok} + Nothing -> + Acid.update keep + <| NewUser + User + { userEmail = UserEmail email, + userGitHubId = GitHubId <. GitHub.untagId <| GitHub.userId ghUser, + userGitHubToken = Encoding.decodeUtf8 tok + } -- * main and test @@ -136,27 +198,51 @@ main = Exception.bracket startup shutdown run cfg <- Envy.decodeWithDefaults Envy.defConfig oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig kp <- Acid.openLocalStateFrom (keep cfg) mempty :: IO (Acid.AcidState Keep) + jwk <- Auth.generateKey putText "@" putText "devalloc" putText <| "port: " <> (show <| port cfg) putText <| "depo: " <> (Text.pack <| depo cfg) putText <| "keep: " <> (Text.pack <| keep cfg) - return (cfg, serve paths (toServant <| htmlApp kp cfg oAuthArgs), kp) + let jwtCfg = Auth.defaultJWTSettings jwk + let cooks = case area cfg of + Test -> devCookieSettings + Live -> Auth.defaultCookieSettings + let ctx = cooks :. jwtCfg :. EmptyContext + let app = serveWithContext paths ctx (toServant <| htmlApp cooks kp cfg jwk oAuthArgs) + return (cfg, app, kp) shutdown :: (Config, Application, Acid.AcidState Keep) -> IO () shutdown (_, _, kp) = Acid.closeAcidState kp run :: (Config, Wai.Application, Acid.AcidState Keep) -> IO () run (cfg, app, _) = Warp.run (port cfg) (logStdout app) +devCookieSettings :: Auth.CookieSettings +devCookieSettings = + Auth.defaultCookieSettings + { Auth.cookieIsSecure = Auth.NotSecure, + Auth.cookieXsrfSetting = Nothing + } + test :: IO Analysis test = test_analyzeGitHub -- * app configurations +data Area = Test | Live + deriving (Generic, Show) + +instance Envy.Var Area where + toVar = show + fromVar "Test" = Just Test + fromVar "Live" = Just Live + fromVar _ = Just Test + data Config = Config { port :: Warp.Port, -- | The repo depo! Depository of repositories! depo :: FilePath, - keep :: FilePath + keep :: FilePath, + area :: Area } deriving (Generic, Show) @@ -165,7 +251,8 @@ instance Envy.DefConfig Config where Config { port = 8005, depo = "_/var/devalloc/depo", - keep = "_/var/devalloc/keep" + keep = "_/var/devalloc/keep", + area = Test } instance Envy.FromEnv Config @@ -197,6 +284,15 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where toHtml (HtmlApp x) = Lucid.doctypehtml_ <| do Lucid.head_ <| do + Lucid.title_ "Devalloc.io :: Know your codebase, know your team." + Lucid.meta_ + [ Lucid.name_ "description", + Lucid.content_ "Know your codebase, know your team." + ] + Lucid.meta_ + [ Lucid.name_ "viewport", + Lucid.content_ "width=device-width, initial-scale=1" + ] Lucid.meta_ [Lucid.charset_ "utf-8"] jsRef "//unpkg.com/turbolinks@5.2.0/dist/turbolinks.js" cssRef "/css/main.css" @@ -219,39 +315,89 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where -- | All of the routes in the app. data Paths path = Paths - { home :: path :- Get '[HTML] (HtmlApp Home), + { home :: + path + :- Get '[Lucid.HTML] (HtmlApp Home), githubAuth :: - path :- "auth" :> "github" :> "callback" + path + :- "auth" + :> "github" + :> "callback" :> QueryParam "code" Text - :> Get '[HTML] (HtmlApp SelectRepo), + :> Get '[Lucid.HTML] (SetCookies (HtmlApp UserHome)), + selectRepo :: + path + :- Auth.Auth '[Auth.Cookie] User + :> "select-repo" + :> Get '[Lucid.HTML] (HtmlApp SelectRepo), githubAnalysis :: - path :- "analysis" :> "github" + path + :- Auth.Auth '[Auth.Cookie] User + :> "analysis" + :> "github" :> Capture "user" Text :> Capture "repo" Text - :> Get '[HTML] (HtmlApp Analysis), - css :: path :- "css" :> "main.css" :> Get '[CSS] Text + :> Get '[Lucid.HTML] (HtmlApp Analysis), + css :: + path + :- "css" + :> "main.css" + :> Get '[CSS] Text } deriving (Generic) +type SetCookies ret = + (Headers '[Header "Set-Cookie" Auth.SetCookie, Header "Set-Cookie" Auth.SetCookie] ret) + paths :: Proxy (ToServantApi Paths) paths = genericApi (Proxy :: Proxy Paths) -- | Main HTML handlers for all paths. -htmlApp :: Acid.AcidState Keep -> Config -> OAuthArgs -> Paths AsServer -htmlApp kp cfg oAuthArgs = +htmlApp :: + Auth.CookieSettings -> + Acid.AcidState Keep -> + Config -> + JWK -> + OAuthArgs -> + Paths AsServer +htmlApp cooks kp cfg jwk oAuthArgs = Paths - { home = page (Home oAuthArgs), - githubAuth = auth kp oAuthArgs, - githubAnalysis = \user repo -> - liftIO <| analyzeGitHub cfg user repo >>= HtmlApp .> pure, - css = look + { home = + pure <. HtmlApp <| Home oAuthArgs, + githubAuth = + auth kp cooks jwk oAuthArgs, + -- TODO: guard on (AuthResult) + selectRepo = \case + Auth.NoSuchUser -> throwError err401 {errBody = "No such user"} + Auth.BadPassword -> throwError err401 {errBody = "Bad password"} + Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"} + Auth.Authenticated user -> do + erepos <- + liftIO + <| GitHub.github + (GitHub.OAuth <. Encoding.encodeUtf8 <| userGitHubToken user) + (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) + case erepos of + Left err -> throwError err502 {errBody = show err} + Right repos -> pure <. HtmlApp <| SelectRepo user repos, + githubAnalysis = \case + Auth.NoSuchUser -> panic "No such user" + Auth.BadPassword -> panic "Bad password" + Auth.Indefinite -> panic "Incorrect authentication method" + Auth.Authenticated user -> \owner repo -> + liftIO + <| analyzeGitHub + (GitHub.OAuth <. Encoding.encodeUtf8 <| userGitHubToken user) + cfg + owner + repo + >>= HtmlApp + .> pure, + css = + return <. toStrict <. Clay.render <| do + Biz.Look.fuckingStyle + "body" Clay.? Biz.Look.fontStack } - where - page = HtmlApp .> pure - look = - return <. toStrict <. Clay.render <| do - Biz.Look.fuckingStyle - "body" Clay.? Biz.Look.fontStack -- | The front page pitch. Eventually I'd like to load the content from markdown -- files or some other store of data so I can A/B test. @@ -288,6 +434,19 @@ instance Lucid.ToHtml Home where Lucid.p_ "(Paid only)" Lucid.toHtml <| loginButton oAuthArgs +newtype UserHome = UserHome User + +instance Lucid.ToHtml UserHome where + toHtmlRaw = Lucid.toHtml + toHtml (UserHome user) = do + Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!" + Lucid.p_ + <| Lucid.a_ + [Lucid.linkHref_ "/" <| fieldLink selectRepo] + "Analyze one of your repos" + where + UserEmail email = userEmail user + -- | A type for parsing JSON auth responses, used in 'getAccessToken' below. -- Should be moved to Biz.Auth with others. data OAuthResponse = OAuthResponse @@ -300,22 +459,36 @@ data OAuthResponse = OAuthResponse -- | Login a user by authenticating with GitHub. auth :: Acid.AcidState Keep -> + Auth.CookieSettings -> + JWK -> OAuthArgs -> Maybe Text -> - Handler (HtmlApp SelectRepo) -auth _ _ Nothing = panic "no code from github api" -auth _ oAuthArgs (Just code) = - liftIO <| getAccessToken oAuthArgs code - >>= getRepos - >>= \case - Left err -> panic <| show err - Right repos -> pure <. HtmlApp <| SelectRepo repos - -getAccessToken :: OAuthArgs -> Text -> IO Text + Handler (SetCookies (HtmlApp UserHome)) +auth _ _ _ _ Nothing = panic "no code from github api" +auth keep cooks jwt oAuthArgs (Just code) = do + token <- liftIO <| getAccessToken oAuthArgs code + eghUser <- liftIO <| (GitHub.github (GitHub.OAuth token) GitHub.userInfoCurrentR :: IO (Either GitHub.Error GitHub.User)) + ghUser <- case eghUser of + Left err -> throwError err502 {errBody = show err} + Right user -> return user + user <- liftIO <| upsertGitHubUser keep token ghUser + mApplyCookies <- liftIO <| Auth.acceptLogin cooks (Auth.defaultJWTSettings jwt) user + case mApplyCookies of + Nothing -> panic "login didn't work" + Just applyCookies -> return <. applyCookies <. HtmlApp <| UserHome user + +-- | POST to GitHub's oAuth service and return the user's oAuth token. +-- TODO: I can also get access scope etc from this response +getAccessToken :: + OAuthArgs -> + Text -> + -- | This should be GitHub.Token but GitHub.Auth doesn't export Token. + IO ByteString getAccessToken OAuthArgs {..} code = accessTokenRequest >>= Req.responseBody /> access_token + /> Encoding.encodeUtf8 /> return |> Req.runReq Req.defaultHttpConfig where @@ -330,19 +503,14 @@ getAccessToken OAuthArgs {..} code = <> "code" =: code <> "state" =: githubState -getRepos :: Text -> IO (Either GitHub.Error (Vector GitHub.Repo)) -getRepos oAuthToken = - GitHub.github - (GitHub.OAuth <| Encoding.encodeUtf8 oAuthToken) - (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) - -- | This view presents a list of repos to select for analysis. -newtype SelectRepo = SelectRepo (Vector GitHub.Repo) +data SelectRepo = SelectRepo User (Vector GitHub.Repo) instance Lucid.ToHtml SelectRepo where toHtmlRaw = Lucid.toHtml - toHtml (SelectRepo repos) = do - Lucid.h1_ "Select a repo to analyze" + toHtml (SelectRepo user repos) = do + Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!" + Lucid.h2_ "Select a repo to analyze" Lucid.ul_ <| forM_ (Vector.toList repos) <| \repo -> Lucid.li_ <. Lucid.a_ @@ -355,6 +523,8 @@ instance Lucid.ToHtml SelectRepo where <. Lucid.toHtml <. GitHub.untagName <| GitHub.repoName repo + where + UserEmail email = userEmail user -- * parts @@ -534,13 +704,15 @@ authorsFor gitDir path = -- | Clones a repo from GitHub and does the analysis. -- TODO: break this up into fetchGitHub and analyze functions. analyzeGitHub :: + GitHub.AuthMethod authMethod => + authMethod -> Config -> -- | GitHub owner Text -> -- | GitHub repo Text -> IO Analysis -analyzeGitHub cfg o r = do +analyzeGitHub githubAuth cfg o r = do -- I currently have no way of getting active users... getting a list of -- collaborators on a repo requires authentication for some reason. -- @@ -556,7 +728,7 @@ analyzeGitHub cfg o r = do -- Right activeUsers <- GitHub.github () (GitHub.collaboratorsOnR ghOwner ghRepo GitHub.FetchAll) Right user <- GitHub.github - () + githubAuth ( GitHub.userInfoForR <| GitHub.mkName (Proxy :: Proxy GitHub.User) o ) @@ -571,7 +743,7 @@ analyzeGitHub cfg o r = do ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r test_analyzeGitHub :: IO Analysis -test_analyzeGitHub = analyzeGitHub Envy.defConfig "bsima" "bin" +test_analyzeGitHub = analyzeGitHub () Envy.defConfig "bsima" "bin" -- | Clone the repo to @/@. If repo already exists, just do a -- @git fetch@. Returns the full path to the local repo. diff --git a/Biz/Devalloc.nix b/Biz/Devalloc.nix index f994892..b7c7503 100644 --- a/Biz/Devalloc.nix +++ b/Biz/Devalloc.nix @@ -37,6 +37,7 @@ in serviceConfig = { Environment = [ "PORT=${toString cfg.port}" + "AREA=Live" ]; EnvironmentFile="/run/devalloc/env"; KillSignal = "INT"; -- cgit v1.2.3