Set subscription in user page, operator precedence

I'm still working on figuring out operator precedence with my custom operators.
The normal precedences don't work well for writing code in a pipeline as I like,
so I have to re-define the operators with my own fixity settings. This will take
some fiddling to get right.

The user subscription allows setting to "Free" only now. It's fine because I
still need to do a design refresh on the pages I just made. One thing I noticed
is that it's getting harder to make changes without breaking stuff, so I either
need to make smaller incremental changes, or actually write some real tests.
I'll probably write tests soon.

1 files changed, 122 insertions, 54 deletions

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index 835d97b..5713db0 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -29,6 +29,7 @@
 -- : dep docopt
 -- : dep envy
 -- : dep github
+-- : dep http-api-data
 -- : dep ixset
 -- : dep lucid
 -- : dep protolude
@@ -56,7 +57,7 @@ import Biz.App (CSS (..), HtmlApp (..))
 import qualified Biz.Cli as Cli
 import qualified Biz.Id as Id
 import qualified Biz.Look
-import Biz.Test ((@=?), (@?!=))
+import Biz.Test ((@?!=), (@=?))
 import qualified Biz.Test as Test
 import qualified CMark as Cmark
 import qualified CMark.Lucid as Cmark
@@ -103,7 +104,7 @@ import qualified System.Directory as Directory
 import qualified System.Envy as Envy
 import System.FilePath ((<.>), (</>))
 import qualified System.Process as Process
-import qualified Web.FormUrlEncoded
+import qualified Web.FormUrlEncoded as Web
 
 -- * persistent data
 
@@ -143,6 +144,12 @@ $(deriveSafeCopy 0 'base ''GitHubId)
 data Subscription = Free | Invoice
   deriving (Eq, Data, Typeable, Ord, Generic, Show)
 
+instance Web.FromForm Subscription where
+  fromForm f = case Web.parseUnique "user-subscription" f of
+    Right "Free" -> Right Free
+    Right x -> Left <| "could not parse form value: " <> x
+    Left x -> Left <| "could not parse form value: " <> x
+
 instance Aeson.ToJSON Subscription
 
 instance Aeson.FromJSON Subscription
@@ -289,8 +296,13 @@ createAnalysis a = do
       }
   return newAnalysis
 
-getAnalyses :: Acid.Query Keep [Analysis]
-getAnalyses = do
+getAnalysisById :: Id.Id Analysis -> Acid.Query Keep (Maybe Analysis)
+getAnalysisById id = do
+  Keep {..} <- ask
+  return <| IxSet.getOne <| analyses @= id
+
+getAllAnalyses :: Acid.Query Keep [Analysis]
+getAllAnalyses = do
   Keep {..} <- ask
   return <| IxSet.toList analyses
 
@@ -302,7 +314,7 @@ getAnalysesByAsker user = do
 getAnalysisByUrlAndCommit :: URL -> Commit -> Acid.Query Keep (Maybe Analysis)
 getAnalysisByUrlAndCommit url sha = do
   Keep {..} <- ask
-  return <| IxSet.getOne <| (analyses @= url &&& analyses @= sha)
+  return <| IxSet.getOne <| analyses @= url &&& analyses @= sha
 
 $( makeAcidic
      ''Keep
@@ -311,7 +323,8 @@ $( makeAcidic
        'getUsers,
        'getUserByEmail,
        'createAnalysis,
-       'getAnalyses,
+       'getAnalysisById,
+       'getAllAnalyses,
        'getAnalysesByAsker,
        'getAnalysisByUrlAndCommit
      ]
@@ -547,17 +560,34 @@ data Paths path = Paths
         :> "github"
         :> "callback"
         :> QueryParam "code" Text
-        :> Get '[Lucid.HTML] (SetCookies (HtmlApp UserHome)),
-    account ::
+        :> Get '[Lucid.HTML] (SetCookies (HtmlApp UserAccount)),
+    getAccount ::
+      path
+        :- Auth.Auth '[Auth.Cookie] User
+        :> "account"
+        :> Get '[Lucid.HTML] (HtmlApp UserAccount),
+    postAccount ::
       path
         :- Auth.Auth '[Auth.Cookie] User
         :> "account"
-        :> Get '[Lucid.HTML] (HtmlApp UserHome),
+        :> ReqBody '[FormUrlEncoded] Subscription
+        :> Post '[Lucid.HTML] (HtmlApp UserAccount),
     selectRepo ::
       path
         :- Auth.Auth '[Auth.Cookie] User
         :> "select-repo"
         :> Get '[Lucid.HTML] (HtmlApp SelectRepo),
+    getAnalyses ::
+      path
+        :- Auth.Auth '[Auth.Cookie] User
+        :> "analysis"
+        :> Get '[Lucid.HTML] (HtmlApp Analyses),
+    getAnalysis ::
+      path
+        :- Auth.Auth '[Auth.Cookie] User
+        :> "analysis"
+        :> Capture "analysisId" (Id.Id Analysis)
+        :> Get '[Lucid.HTML] (HtmlApp AnalysisDisplay),
     githubAnalysis ::
       path
         :- Auth.Auth '[Auth.Cookie] User
@@ -595,13 +625,19 @@ htmlApp cooks kp cfg jwk oAuthArgs =
       login = pure <| addHeader (githubLoginUrl oAuthArgs) NoContent,
       githubAuth =
         auth kp cooks jwk oAuthArgs,
-      account = \case
+      getAccount = \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@User {..} -> do
-          analyses <- Acid.query' kp <| GetAnalysesByAsker user
-          pure <| HtmlApp <| UserHome user analyses,
+          pure <| HtmlApp <| UserAccount user,
+      postAccount = \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@User {..} -> \subscription -> do
+          newuser <- Acid.update' kp <| UpdateUser user {userSubscription = subscription}
+          pure <| HtmlApp <| UserAccount newuser,
       selectRepo = \case
         Auth.NoSuchUser -> throwError err401 {errBody = "No such user"}
         Auth.BadPassword -> throwError err401 {errBody = "Bad password"}
@@ -615,18 +651,32 @@ htmlApp cooks kp cfg jwk oAuthArgs =
           case erepos of
             Left err -> throwError err502 {errBody = show err}
             Right repos -> pure <. HtmlApp <| SelectRepo user repos,
+      getAnalyses = \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@User {..} -> do
+          analyses <- Acid.query' kp <| GetAnalysesByAsker user
+          pure <| HtmlApp <| Analyses user analyses,
+      getAnalysis = \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 -> \analysisId ->
+          do
+            -- Acid.query' kp ( GetAnalysisById analysisId) >>= \case
+            GetAnalysisById analysisId
+            |> Acid.query' kp
+            >>= \case
+              Nothing -> panic "404"
+              Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis,
       githubAnalysis = \case
-        Auth.NoSuchUser -> panic "No such user"
-        Auth.BadPassword -> panic "Bad password"
-        Auth.Indefinite -> panic "Incorrect authentication method"
+        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@User {..} -> \owner repo ->
-          liftIO
-            <| analyzeGitHub
-              kp
-              user
-              cfg
-              owner
-              repo
+          analyzeGitHub kp user cfg owner repo
+            |> liftIO
             >>= AnalysisDisplay user
             .> HtmlApp
             .> pure,
@@ -780,42 +830,58 @@ instance Lucid.ToHtml Home where
       h1 = Lucid.h1_
       h2 = Lucid.h2_ <. markdown
 
-data UserHome = UserHome User [Analysis]
+data Analyses = Analyses User [Analysis]
+
+instance Lucid.ToHtml Analyses where
+  toHtmlRaw = Lucid.toHtml
+  toHtml (Analyses user@User {..} analyses) = do
+    header <| Just user
+    Lucid.main_ <| do
+      Lucid.section_ <| do
+        Lucid.h2_ "Your Analyses"
+        Lucid.p_
+          <| Lucid.a_
+            [Lucid.linkHref_ "/" <| fieldLink selectRepo]
+            "Analyze one of your repos"
+        Lucid.div_ <| do
+          forM_ analyses <| \Analysis {..} ->
+            Lucid.a_ [href analysisId, style <| Biz.Look.marginAll (em 1)] <| do
+              Lucid.div_ <| Lucid.toHtml url
+              Lucid.div_ [style <| Clay.fontSizeCustom Clay.Font.small]
+                <| Lucid.toHtml commit
+    footer
+    where
+      href aid = Lucid.linkHref_ "/" <| fieldLink getAnalysis aid
+
+newtype UserAccount = UserAccount User
 
 instance Lucid.ToHtml Subscription where
   toHtmlRaw = Lucid.toHtml
   toHtml Free = "Free"
   toHtml Invoice = "Invoice me"
 
-instance Lucid.ToHtml UserHome where
+linkAction_ :: ToHttpApiData a => Text -> a -> Lucid.Attribute
+linkAction_ baseUrl = Lucid.action_ <. (baseUrl <>) <. Servant.toUrlPiece
+
+instance Lucid.ToHtml UserAccount where
   toHtmlRaw = Lucid.toHtml
-  toHtml (UserHome user@User {..} analyses) = do
+  toHtml (UserAccount user@User {..}) = do
     header <| Just user
     Lucid.main_ <| do
       Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!"
       Lucid.section_ <| do
         Lucid.h2_ "Subscription"
-        Lucid.p_ <| do
-          "You are currently on the "
-          Lucid.strong_ <| Lucid.toHtml userSubscription
-          " plan."
+        let action = linkAction_ "/" <| fieldLink postAccount
+        Lucid.form_ [action, Lucid.method_ "post"] <| do
+          let name = "user-subscription"
+          Lucid.label_ [Lucid.for_ name] "Your plan:"
+          Lucid.select_ [Lucid.name_ name] <| do
+            Lucid.option_ [Lucid.value_ "Free"] <| Lucid.toHtml userSubscription
+          Lucid.input_ [Lucid.type_ "submit", Lucid.value_ "Save"]
         when (userSubscription == Invoice) <| do
           Lucid.p_ "You will received an invoice by email next month."
-      Lucid.section_ <| do
-        Lucid.h2_ "Your Analyses"
-        Lucid.div_ <| do
-          forM_ analyses <| \Analysis {..} ->
-            Lucid.a_ [{- href analysisId, -} style <| Biz.Look.marginAll (em 1)] <| do
-              Lucid.div_ <| Lucid.toHtml url
-              Lucid.div_ [style <| Clay.fontSizeCustom Clay.Font.small]
-                <| Lucid.toHtml commit
-      Lucid.p_
-        <| Lucid.a_
-          [Lucid.linkHref_ "/" <| fieldLink selectRepo]
-          "Analyze one of your repos"
     footer
     where
-      -- href aid = Lucid.linkHref_ "/" <| fieldLink analysis analysisId
       UserEmail email = userEmail
 
 style :: Clay.Css -> Lucid.Attribute
@@ -837,7 +903,7 @@ auth ::
   JWK ->
   OAuthArgs ->
   Maybe Text ->
-  Handler (SetCookies (HtmlApp UserHome))
+  Handler (SetCookies (HtmlApp UserAccount))
 auth _ _ _ _ Nothing = panic "no code from github api"
 auth keep cooks jwt oAuthArgs (Just code) = do
   token <- liftIO <| getAccessToken oAuthArgs code
@@ -847,11 +913,10 @@ auth keep cooks jwt oAuthArgs (Just code) = do
     Right user -> return user
   user <- liftIO <| upsertGitHubUser keep token ghUser
   mApplyCookies <- liftIO <| Auth.acceptLogin cooks (Auth.defaultJWTSettings jwt) user
-  analyses <- Acid.query' keep <| GetAnalysesByAsker user
   case mApplyCookies of
     Nothing -> panic "login didn't work"
-    -- I think this should redirect to instead of rendering UserHome
-    Just applyCookies -> return <. applyCookies <. HtmlApp <| UserHome user analyses
+    -- I think this should redirect to instead of rendering UserAccount
+    Just applyCookies -> return <. applyCookies <. HtmlApp <| UserAccount 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
@@ -861,13 +926,14 @@ getAccessToken ::
   -- | 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
+  Req.runReq Req.defaultHttpConfig <| do
+    x <- accessTokenRequest
+    Req.responseBody x
+      |> access_token
+      |> Encoding.encodeUtf8
+      |> return
   where
+    accessTokenRequest :: Req.Req (Req.JsonResponse OAuthResponse)
     accessTokenRequest =
       Req.req
         Req.POST
@@ -922,7 +988,7 @@ encodeParams :: [(Text, Text)] -> Text
 encodeParams =
   Encoding.decodeUtf8
     <. LBS.toStrict
-    <. Web.FormUrlEncoded.urlEncodeParams
+    <. Web.urlEncodeParams
 
 -- | Login button for GitHub.
 tryButton :: OAuthArgs -> Lucid.Html ()
@@ -945,7 +1011,9 @@ header muser =
             li "Login" <| fieldLink login
             li "Pricing" <| fieldLink home
         Just _ ->
-          Lucid.ul_ <. li "My Account" <| fieldLink account
+          Lucid.ul_ <| do
+            li "Analyses" <| fieldLink getAnalyses
+            li "Account" <| fieldLink getAccount
   where
     a txt href =
       Lucid.a_ [Lucid.linkHref_ "/" href] txt