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.

8 files changed, 175 insertions, 71 deletions

diff --git a/Alpha.hs b/Alpha.hs
index 7da7161..7405103 100644
--- a/Alpha.hs
+++ b/Alpha.hs
@@ -41,6 +41,10 @@ module Alpha
     (</),
     (<//),
 
+    -- * Shoving / binding
+    bind,
+    (>>=),
+
     -- * Bool
     don't,
 
@@ -73,7 +77,8 @@ import Data.String
 import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as LazyText
-import Protolude as X hiding (list, ($), (&), (.))
+import Protolude as X hiding (list, ($), (&), (.), (>>=))
+import qualified Prelude
 
 -- | Create a list. This should be @Data.List.singleton@ but that doesn't exist.
 list :: a -> [a]
@@ -93,7 +98,7 @@ compose f g x = g (f x)
 (.>) :: (a -> b) -> (b -> c) -> (a -> c)
 f .> g = compose f g
 
-infixl 9 .>
+-- infixl 0 .>
 
 -- | Left-composition operator
 --
@@ -101,7 +106,7 @@ infixl 9 .>
 (<.) :: (b -> c) -> (a -> b) -> (a -> c)
 g <. f = compose f g
 
-infixr 9 <.
+-- infixr 0 <.
 
 -- | Alias for map, fmap, <$>
 --
@@ -109,6 +114,8 @@ infixr 9 <.
 (</) :: Functor f => (a -> b) -> f a -> f b
 f </ g = fmap f g
 
+-- infixr 1 </
+
 -- | Double fmap. A function on the left goes "into" two functors
 -- (i.e. it goes "two levels deep"), applies the function to the inner
 -- values, then returns the result wrapped in the two functors.
@@ -117,6 +124,8 @@ f </ g = fmap f g
 (<//) :: (Functor f0, Functor f1) => (a -> b) -> f0 (f1 a) -> f0 (f1 b)
 (<//) = fmap .> fmap
 
+-- infixr 1 <//
+
 -- | Normal function application. Do the right side, then pass the
 -- return value to the function on the left side.
 --
@@ -124,7 +133,7 @@ f </ g = fmap f g
 (<|) :: (a -> b) -> a -> b
 f <| g = f g
 
-infixr 0 <|
+infixr 1 <|
 
 -- | Reverse function application. Do the left side, then pass the
 -- return value to the function on the right side.
@@ -143,6 +152,16 @@ infixl 1 |>
 (/>) :: Functor f => f a -> (a -> b) -> f b
 f /> g = fmap g f
 
+infixl 1 />
+
+bind :: Monad m => m a -> (a -> m b) -> m b
+bind a f = a Prelude.>>= f
+
+(>>=) :: Monad m => m a -> (a -> m b) -> m b
+a >>= b = a Prelude.>>= b
+
+infixl 1 >>=
+
 -- | Removes newlines from text.
 chomp :: Text -> Text
 chomp = Text.filter (/= '\n')
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
diff --git a/Biz/Id.hs b/Biz/Id.hs
index 9bce013..4635f7f 100644
--- a/Biz/Id.hs
+++ b/Biz/Id.hs
@@ -14,6 +14,7 @@ import Alpha
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.Binary (Binary)
 import Data.Data (Data)
+import Servant (FromHttpApiData (..), ToHttpApiData (..))
 
 newtype Id entity = Id Int
   deriving (Eq, Ord, Show, Generic, Typeable, Data)
@@ -47,3 +48,9 @@ instance Semigroup (Id entity) where
 
 instance Monoid (Id entity) where
   mempty = mk (Proxy :: Proxy entity) 0
+
+instance FromHttpApiData (Id entity) where
+  parseUrlPiece p = mk (Proxy :: Proxy entity) </ parseUrlPiece p
+
+instance ToHttpApiData (Id entity) where
+  toUrlPiece p = untag p |> tshow
diff --git a/Biz/Lint.hs b/Biz/Lint.hs
index 8689308..66c7900 100644
--- a/Biz/Lint.hs
+++ b/Biz/Lint.hs
@@ -32,7 +32,7 @@ move args = case Cli.getAllArgs args (Cli.argument "file") of
   files ->
     files
       |> filter notcab
-      /> filterM Directory.doesFileExist
+      |> filterM Directory.doesFileExist
       >>= run
       >>= exit
 
diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs
index d50993c..cbf4bfd 100644
--- a/Biz/Que/Host.hs
+++ b/Biz/Que/Host.hs
@@ -166,10 +166,12 @@ routes cfg = do
     authkey <- fromMaybe "" </ Scotty.header "Authorization"
     (ns, qp) <- extract
     -- Only allow my IP or localhost to publish to '_' namespace
-    when ("_" == ns && authkey /= (Text.Lazy.strip <| queSkey cfg))
-      <| Scotty.status Http.methodNotAllowed405
-      >> Scotty.text "not allowed: _ is a reserved namespace"
-      >> Scotty.finish
+    when
+      ("_" == ns && authkey /= (Text.Lazy.strip <| queSkey cfg))
+      ( Scotty.status Http.methodNotAllowed405
+          >> Scotty.text "not allowed: _ is a reserved namespace"
+          >> Scotty.finish
+      )
     guardNs ns ["pub", "_"]
     -- passed all auth checks
     app <. modify <| upsertNamespace ns
diff --git a/Biz/Que/Site.hs b/Biz/Que/Site.hs
index c2245d6..3e456da 100644
--- a/Biz/Que/Site.hs
+++ b/Biz/Que/Site.hs
@@ -111,11 +111,11 @@ run key ns Sources {..} = Async.runConcurrently actions |> void
     actions =
       traverse
         Async.Concurrently
-        [ forever <| toHtml index >>= serve key ns "index",
-          forever <| toHtml quescripts >>= serve key ns "quescripts",
-          forever <| BS.readFile client >>= serve key ns "client",
-          forever <| toHtml tutorial >>= serve key ns "tutorial",
-          forever <| toHtml apidocs >>= serve key ns "apidocs"
+        [ toHtml index >>= serve key ns "index" |> forever,
+          toHtml quescripts >>= serve key ns "quescripts" |> forever,
+          BS.readFile client >>= serve key ns "client" |> forever,
+          toHtml tutorial >>= serve key ns "tutorial" |> forever,
+          toHtml apidocs >>= serve key ns "apidocs" |> forever
         ]
     toHtml :: FilePath -> IO ByteString
     toHtml md =
diff --git a/Biz/Test.hs b/Biz/Test.hs
index db71831..85c405f 100644
--- a/Biz/Test.hs
+++ b/Biz/Test.hs
@@ -18,7 +18,6 @@ where
 
 import Alpha hiding (group)
 import qualified Test.Tasty as Tasty
-import Test.Tasty.HUnit ((@=?), (@?=))
 import qualified Test.Tasty.HUnit as HUnit
 import qualified Test.Tasty.QuickCheck as QuickCheck
 
@@ -74,3 +73,13 @@ assertNotEqual preface notexpected actual =
   a ->
   HUnit.Assertion
 expected @?!= actual = assertNotEqual "" expected actual
+
+infixl 2 @?!=
+
+(@=?) :: (Eq a, Show a) => a -> a -> HUnit.Assertion
+a @=? b = a HUnit.@=? b
+infixl 2 @=?
+
+(@?=) :: (Eq a, Show a) => a -> a -> HUnit.Assertion
+a @?= b = a HUnit.@?= b
+infixr 2 @?=
diff --git a/Hero/Node.hs b/Hero/Node.hs
index 38f540d..e7eb687 100644
--- a/Hero/Node.hs
+++ b/Hero/Node.hs
@@ -53,7 +53,6 @@ import qualified Miso.FFI.Document as Document
 import qualified Miso.FFI.Fullscreen as Fullscreen
 import Miso.String
 import qualified Network.RemoteData as Network
-import Protolude
 
 -- | Entry point for a miso application
 main :: IO ()
@@ -143,7 +142,7 @@ move (ToggleInLibrary c) form = form {user = newUser} <# pure NoOp
     newUser = (user form) {userLibrary = newLib}
     newLib
       | c `elem` (userLibrary <| user form) =
-        Protolude.filter (/= c) <| userLibrary <| user form
+        Alpha.filter (/= c) <| userLibrary <| user form
       | otherwise = c : (userLibrary <| user form)
 move (HandleURI u) form = form {uri = u} <# pure NoOp
 move (ChangeURI u) form =