Skip to content

Instantly share code, notes, and snippets.

@benkolera

benkolera/norecord.patch

Created June 16, 2019 04:51
Show Gist options
  • Save benkolera/9b2fcfc458eccd7f3a3b2f5542bb8382 to your computer and use it in GitHub Desktop.
Save benkolera/9b2fcfc458eccd7f3a3b2f5542bb8382 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
norecord.patch
diff --git a/src-ui.v3/src/API.hs b/src-ui.v3/src/API.hs
index d93e209..cae595d 100644
--- a/src-ui.v3/src/API.hs
+++ b/src-ui.v3/src/API.hs
@@ -7,6 +7,7 @@
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
-- {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
@@ -303,61 +304,52 @@ type API = "v2" :> "idxstates" :> "latest" :> Get '[JSON] PkgIdxTs
:<|> "v2" :> "workers" :> Get '[JSON] (Vector WorkerRow)
:<|> "v2" :> "workers" :> Capture "pkgname" PkgN :> Get '[JSON] (Vector WorkerRow)
---- The following Type API is heavily inspired by QFPL's reflex-realworld-example: https://github.com/qfpl/reflex-realworld-example
-data ClientFuns t m = ClientFuns
- { _getV2IdxStates :: Event t () -> m (Event t (ReqResult () PkgIdxTs))
- , _getV2Info :: Event t () -> m (Event t (ReqResult () ControllerInfo))
- , _getV2Packages :: Event t () -> m (Event t (ReqResult () (Vector PkgN)))
- , _getV2PackagesHistory :: Dynamic t (QParam PkgIdxTs) -> Dynamic t (QParam PkgIdxTs) -> Event t () -> m (Event t (ReqResult () (Vector IdxHistoryEntry)))
- , _getV2PackageHistory :: Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () (Vector PkgHistoryEntry)))
- , _getV2PackageReports :: Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () (Set PkgIdxTs)))
- , _getV2PackageReportSummary :: Dynamic t (Either Text PkgN) -> Dynamic t (Either Text PkgIdxTs) -> Event t () -> m (Event t (ReqResult () PkgIdxTsReport))
- , _getV2PackageReportDetail :: Dynamic t (Either Text PkgN) -> Dynamic t (Either Text PkgIdxTs) -> Dynamic t (Either Text Ver) -> Dynamic t (Either Text CompilerID) -> Event t () -> m (Event t (ReqResult () CellReportDetail))
- , _getV2PackageTags :: Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () (Vector TagN)))
- , _getV2Queue :: Event t () -> m (Event t (ReqResult () (Vector QEntryRow)))
- , _getV2QueuePkg :: Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () (Vector QEntryRow)))
- , _putV2Queue :: Dynamic t (Either Text PkgN) -> Dynamic t (Either Text PkgIdxTs) -> Dynamic t (Either Text QEntryUpd) -> Event t () -> m (Event t (ReqResult () (QEntryRow)))
- , _getV2TagsWithPackage :: Dynamic t (QParam Bool) -> Event t () -> m (Event t (ReqResult () (Map TagN (Vector PkgN))))
- , _getV2TagsWithoutPackage :: Dynamic t (QParam Bool) -> Event t () -> m (Event t (ReqResult () (Vector TagN)))
- , _putV2PackageTags :: Dynamic t (Either Text TagN) -> Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () NoContent))
- , _deleteV2PackageTags :: Dynamic t (Either Text TagN) -> Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () NoContent))
- , _getV2UnitInfo :: Dynamic t (Either Text UUID) -> Event t () -> m (Event t (ReqResult () UnitIdInfo))
- , _getV2User :: Dynamic t (Either Text UserName) -> Event t () -> m (Event t (ReqResult () UserPkgs))
- , _getV2Workers :: Event t () -> m (Event t (ReqResult () (Vector WorkerRow)))
- , _getV2WorkersPkg :: Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () (Vector WorkerRow)))
- }
-makeLenses ''ClientFuns
-
-getClient :: forall t m. (SupportsServantReflex t m)
- => ClientFuns t m
-getClient = mkClientFuns'' burlNew
- where
- mkClientFuns'' bp = ClientFuns { .. }
- where
- ( _getV2IdxStates
- :<|> _getV2Info
- :<|> _getV2Packages
- :<|> _getV2PackagesHistory
- :<|> _getV2PackageHistory
- :<|> _getV2PackageReports
- :<|> _getV2PackageReportSummary
- :<|> _getV2PackageReportDetail
- :<|> _getV2PackageTags
- :<|> _getV2Queue
- :<|> _getV2QueuePkg
- :<|> _putV2Queue
- :<|> _getV2TagsWithPackage
- :<|> _getV2TagsWithoutPackage
- :<|> _putV2PackageTags
- :<|> _deleteV2PackageTags
- :<|> _getV2UnitInfo
- :<|> _getV2User
- :<|> _getV2Workers
- :<|> _getV2WorkersPkg ) = (clientWithOpts (Proxy :: Proxy API) Proxy (Proxy :: Proxy ()) (constDyn bp) tweakRequest) :: Client t m API ()
+getV2IdxStates :: SupportsServantReflex t m => Event t () -> m (Event t (ReqResult () PkgIdxTs))
+getV2Info :: SupportsServantReflex t m => Event t () -> m (Event t (ReqResult () ControllerInfo))
+getV2Packages :: SupportsServantReflex t m => Event t () -> m (Event t (ReqResult () (Vector PkgN)))
+getV2PackagesHistory :: SupportsServantReflex t m => Dynamic t (QParam PkgIdxTs) -> Dynamic t (QParam PkgIdxTs) -> Event t () -> m (Event t (ReqResult () (Vector IdxHistoryEntry)))
+getV2PackageHistory :: SupportsServantReflex t m => Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () (Vector PkgHistoryEntry)))
+getV2PackageReports :: SupportsServantReflex t m => Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () (Set PkgIdxTs)))
+getV2PackageReportSummary :: SupportsServantReflex t m => Dynamic t (Either Text PkgN) -> Dynamic t (Either Text PkgIdxTs) -> Event t () -> m (Event t (ReqResult () PkgIdxTsReport))
+getV2PackageReportDetail :: SupportsServantReflex t m => Dynamic t (Either Text PkgN) -> Dynamic t (Either Text PkgIdxTs) -> Dynamic t (Either Text Ver) -> Dynamic t (Either Text CompilerID) -> Event t () -> m (Event t (ReqResult () CellReportDetail))
+getV2PackageTags :: SupportsServantReflex t m => Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () (Vector TagN)))
+getV2Queue :: SupportsServantReflex t m => Event t () -> m (Event t (ReqResult () (Vector QEntryRow)))
+getV2QueuePkg :: SupportsServantReflex t m => Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () (Vector QEntryRow)))
+putV2Queue :: SupportsServantReflex t m => Dynamic t (Either Text PkgN) -> Dynamic t (Either Text PkgIdxTs) -> Dynamic t (Either Text QEntryUpd) -> Event t () -> m (Event t (ReqResult () (QEntryRow)))
+getV2TagsWithPackage :: SupportsServantReflex t m => Dynamic t (QParam Bool) -> Event t () -> m (Event t (ReqResult () (Map TagN (Vector PkgN))))
+getV2TagsWithoutPackage :: SupportsServantReflex t m => Dynamic t (QParam Bool) -> Event t () -> m (Event t (ReqResult () (Vector TagN)))
+putV2PackageTags :: SupportsServantReflex t m => Dynamic t (Either Text TagN) -> Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () NoContent))
+deleteV2PackageTags :: SupportsServantReflex t m => Dynamic t (Either Text TagN) -> Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () NoContent))
+getV2UnitInfo :: SupportsServantReflex t m => Dynamic t (Either Text UUID) -> Event t () -> m (Event t (ReqResult () UnitIdInfo))
+getV2User :: SupportsServantReflex t m => Dynamic t (Either Text UserName) -> Event t () -> m (Event t (ReqResult () UserPkgs))
+getV2Workers :: SupportsServantReflex t m => Event t () -> m (Event t (ReqResult () (Vector WorkerRow)))
+getV2WorkersPkg :: SupportsServantReflex t m => Dynamic t (Either Text PkgN) -> Event t () -> m (Event t (ReqResult () (Vector WorkerRow)))
+
+getV2IdxStates
+ :<|> getV2Info
+ :<|> getV2Packages
+ :<|> getV2PackagesHistory
+ :<|> getV2PackageHistory
+ :<|> getV2PackageReports
+ :<|> getV2PackageReportSummary
+ :<|> getV2PackageReportDetail
+ :<|> getV2PackageTags
+ :<|> getV2Queue
+ :<|> getV2QueuePkg
+ :<|> putV2Queue
+ :<|> getV2TagsWithPackage
+ :<|> getV2TagsWithoutPackage
+ :<|> putV2PackageTags
+ :<|> deleteV2PackageTags
+ :<|> getV2UnitInfo
+ :<|> getV2User
+ :<|> getV2Workers
+ :<|> getV2WorkersPkg =
+ clientWithOpts (Proxy :: Proxy API) Proxy (Proxy :: Proxy ()) (constDyn burlNew) tweakRequest
type ValidationErrors = Map Text [Text]
type ClientRes t a = (Event t a, Event t ClientError, Dynamic t Bool)
-
+
data ClientError
= Forbidden
| NotFound
@@ -365,12 +357,12 @@ data ClientError
| FailedValidation (Maybe (ErrorBody ValidationErrors))
| OtherError Word Text
deriving (Show)
-
+
data ErrorBody errors = ErrorBody
{ message :: Text
, errors :: Maybe errors
} deriving (Generic, Show)
-
+
deriving instance ToJSON errors => ToJSON (ErrorBody errors)
deriving instance FromJSON errors => FromJSON (ErrorBody errors)
@@ -394,31 +386,28 @@ reqClientError (ResponseFailure _ msg xhrR) = Just $ case view xhrResponse_statu
w -> OtherError w msg
reqClientError _ = Nothing
-fill :: a -> Getting f (a -> b) b
-fill a = to ($ a)
-
getIdxStates :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m) => Event t () -> m (ClientRes t (PkgIdxTs))
getIdxStates evSubmit = do
- evResult <- getClient ^. getV2IdxStates . fill evSubmit
+ evResult <- getV2IdxStates evSubmit
wireClientRes evSubmit evResult
getInfo :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m) => Event t () -> m (ClientRes t (ControllerInfo))
getInfo evSubmit = do
- evResult <- getClient ^. getV2Info . fill evSubmit
+ evResult <- getV2Info evSubmit
wireClientRes evSubmit evResult
getPackages :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m) => Event t () -> m (ClientRes t (Vector PkgN))
getPackages evSubmit = do
- evResult <- getClient ^. getV2Packages . fill evSubmit
+ evResult <- getV2Packages evSubmit
wireClientRes evSubmit evResult
-getPackagesHistory :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
- => Dynamic t (QParam PkgIdxTs)
- -> Dynamic t (QParam PkgIdxTs)
- -> Event t ()
+getPackagesHistory :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
+ => Dynamic t (QParam PkgIdxTs)
+ -> Dynamic t (QParam PkgIdxTs)
+ -> Event t ()
-> m (ClientRes t (Vector IdxHistoryEntry))
getPackagesHistory minDyn maxDyn evSubmit = do
- evResult <- getClient ^. getV2PackagesHistory . fill minDyn . fill maxDyn . fill evSubmit
+ evResult <- getV2PackagesHistory minDyn maxDyn evSubmit
wireClientRes evSubmit evResult
getPackageHistory :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
@@ -426,24 +415,24 @@ getPackageHistory :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold
-> Event t ()
-> m (ClientRes t (Vector PkgHistoryEntry))
getPackageHistory pkgNDyn evSubmit = do
- evResult <- getClient ^. getV2PackageHistory . fill pkgNDyn . fill evSubmit
+ evResult <- getV2PackageHistory pkgNDyn evSubmit
wireClientRes evSubmit evResult
getPackageReports :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
- => Dynamic t (Either Text PkgN)
- -> Event t ()
+ => Dynamic t (Either Text PkgN)
+ -> Event t ()
-> m (ClientRes t (Set PkgIdxTs))
getPackageReports pkgNDyn evSubmit = do
- evResult <- getClient ^. getV2PackageReports . fill pkgNDyn . fill evSubmit
+ evResult <- getV2PackageReports pkgNDyn evSubmit
wireClientRes evSubmit evResult
-
+
getPackageReportSummary :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
=> Dynamic t (Either Text PkgN)
-> Dynamic t (Either Text PkgIdxTs)
-> Event t ()
-> m (ClientRes t PkgIdxTsReport)
getPackageReportSummary pkgNDyn pkgIdxDyn evSubmit = do
- evResult <- getClient ^. getV2PackageReportSummary . fill pkgNDyn . fill pkgIdxDyn . fill evSubmit
+ evResult <- getV2PackageReportSummary pkgNDyn pkgIdxDyn evSubmit
wireClientRes evSubmit evResult
getPackageReportDetail :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
@@ -454,82 +443,82 @@ getPackageReportDetail :: forall t m. (Reflex t, SupportsServantReflex t m, Mona
-> Event t ()
-> m (ClientRes t CellReportDetail)
getPackageReportDetail pkgNDyn pkgIdxDyn verDyn compilerDyn evSubmit = do
- evResult <- getClient ^. getV2PackageReportDetail . fill pkgNDyn . fill pkgIdxDyn . fill verDyn . fill compilerDyn . fill evSubmit
+ evResult <- getV2PackageReportDetail pkgNDyn pkgIdxDyn verDyn compilerDyn evSubmit
wireClientRes evSubmit evResult
getPackageTags :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
- => Dynamic t (Either Text PkgN)
- -> Event t ()
+ => Dynamic t (Either Text PkgN)
+ -> Event t ()
-> m (ClientRes t (Vector TagN))
getPackageTags pkgNDyn evSubmit = do
- evResult <- getClient ^. getV2PackageTags . fill pkgNDyn . fill evSubmit
- wireClientRes evSubmit evResult
+ evResult <- getV2PackageTags pkgNDyn evSubmit
+ wireClientRes evSubmit evResult
getQueue :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
=> Event t ()
-> m (ClientRes t (Vector QEntryRow))
getQueue evSubmit = do
- evResult <- getClient ^. getV2Queue . fill evSubmit
+ evResult <- getV2Queue evSubmit
wireClientRes evSubmit evResult
-getQueuePkg :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
+getQueuePkg :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
=> Dynamic t (Either Text PkgN)
-> Event t ()
-> m (ClientRes t (Vector QEntryRow))
getQueuePkg pkgNDyn evSubmit = do
- evResult <- getClient ^. getV2QueuePkg . fill pkgNDyn . fill evSubmit
- wireClientRes evSubmit evResult
+ evResult <- getV2QueuePkg pkgNDyn evSubmit
+ wireClientRes evSubmit evResult
-putQueue :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
+putQueue :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
=> Dynamic t (Either Text PkgN)
-> Dynamic t (Either Text PkgIdxTs)
-> Dynamic t (Either Text QEntryUpd)
-> Event t ()
-> m (ClientRes t (QEntryRow))
putQueue pkgNDyn pkgIdxDyn qEntryDyn evSubmit = do
- evResult <- getClient ^. putV2Queue . fill pkgNDyn . fill pkgIdxDyn . fill qEntryDyn . fill evSubmit
+ evResult <- putV2Queue pkgNDyn pkgIdxDyn qEntryDyn evSubmit
wireClientRes evSubmit evResult
-getTagsPkg :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
- => Dynamic t (QParam Bool)
- -> Event t ()
+getTagsPkg :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
+ => Dynamic t (QParam Bool)
+ -> Event t ()
-> m (ClientRes t (Map TagN (Vector PkgN)))
getTagsPkg dynBool evSubmit = do
- evResult <- getClient ^. getV2TagsWithPackage . fill dynBool . fill evSubmit
+ evResult <- getV2TagsWithPackage dynBool evSubmit
wireClientRes evSubmit evResult
getTags :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
- => Dynamic t (QParam Bool)
- -> Event t ()
+ => Dynamic t (QParam Bool)
+ -> Event t ()
-> m (ClientRes t (Vector TagN))
getTags dynBool evSubmit = do
- evResult <- getClient ^. getV2TagsWithoutPackage . fill dynBool . fill evSubmit
+ evResult <- getV2TagsWithoutPackage dynBool evSubmit
wireClientRes evSubmit evResult
putTags :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
- => Dynamic t (Either Text TagN)
- -> Dynamic t (Either Text PkgN)
- -> Event t ()
+ => Dynamic t (Either Text TagN)
+ -> Dynamic t (Either Text PkgN)
+ -> Event t ()
-> m (ClientRes t NoContent)
putTags tagNDyn pkgNDyn evSubmit = do
- evResult <- getClient ^. putV2PackageTags . fill tagNDyn . fill pkgNDyn . fill evSubmit
+ evResult <- putV2PackageTags tagNDyn pkgNDyn evSubmit
wireClientRes evSubmit evResult
deleteTags :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
- => Dynamic t (Either Text TagN)
- -> Dynamic t (Either Text PkgN)
- -> Event t ()
+ => Dynamic t (Either Text TagN)
+ -> Dynamic t (Either Text PkgN)
+ -> Event t ()
-> m (ClientRes t NoContent)
deleteTags tagNDyn pkgNDyn evSubmit = do
- evResult <- getClient ^. deleteV2PackageTags . fill tagNDyn . fill pkgNDyn . fill evSubmit
- wireClientRes evSubmit evResult
+ evResult <- deleteV2PackageTags tagNDyn pkgNDyn evSubmit
+ wireClientRes evSubmit evResult
getUnitInfo :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
- => Dynamic t (Either Text UUID)
- -> Event t ()
+ => Dynamic t (Either Text UUID)
+ -> Event t ()
-> m (ClientRes t (UnitIdInfo))
getUnitInfo uuidDyn evSubmit = do
- evResult <- getClient ^. getV2UnitInfo . fill uuidDyn . fill evSubmit
+ evResult <- getV2UnitInfo uuidDyn evSubmit
wireClientRes evSubmit evResult
getUser :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
@@ -537,23 +526,23 @@ getUser :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
-> Event t ()
-> m (ClientRes t UserPkgs)
getUser usrNDyn evSubmit = do
- evResult <- getClient ^. getV2User . fill usrNDyn . fill evSubmit
+ evResult <- getV2User usrNDyn evSubmit
wireClientRes evSubmit evResult
getWorkers :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
=> Event t ()
-> m (ClientRes t (Vector WorkerRow))
getWorkers evSubmit = do
- evResult <- getClient ^. getV2Workers . fill evSubmit
- wireClientRes evSubmit evResult
+ evResult <- getV2Workers evSubmit
+ wireClientRes evSubmit evResult
-getWorkersPkg :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
+getWorkersPkg :: forall t m. (Reflex t, SupportsServantReflex t m, MonadHold t m)
=> Dynamic t (Either Text PkgN)
-> Event t ()
-> m (ClientRes t (Vector WorkerRow))
getWorkersPkg pkgNDyn evSubmit = do
- evResult <- getClient ^. getV2WorkersPkg . fill pkgNDyn . fill evSubmit
- wireClientRes evSubmit evResult
+ evResult <- getV2WorkersPkg pkgNDyn evSubmit
+ wireClientRes evSubmit evResult
----------------------------------------------------------------------------
burlNew :: BaseUrl
burlNew | True = BaseFullUrl Https "matrix.hackage.haskell.org" 443 "/api"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment