Reorganize code (#30)

hie.yaml

@@ -24,7 +24,7 @@ cradle:
     - path: "./src/Language/Marlowe/Runtime/Background.hs"
       component: "marlowe-explorer:lib"
 
-    - path: "./src/Language/Marlowe/Runtime/Types/Common.hs"
+    - path: "./src/Language/Marlowe/Runtime/ContractCaching.hs"
       component: "marlowe-explorer:lib"
 
     - path: "./src/Language/Marlowe/Runtime/Types/ContractJSON.hs"
@@ -39,6 +39,9 @@ cradle:
     - path: "./src/Language/Marlowe/Runtime/Types/LazyFeed.hs"
       component: "marlowe-explorer:lib"
 
+    - path: "./src/Language/Marlowe/Runtime/Types/TransactionsJSON.hs"
+      component: "marlowe-explorer:lib"
+
     - path: "./src/Language/Marlowe/Semantics/Types.hs"
       component: "marlowe-explorer:lib"
 

marlowe-explorer.cabal

@@ -31,11 +31,12 @@ library
       Explorer.Web.Util
       Language.Marlowe.Pretty
       Language.Marlowe.Runtime.Background
-      Language.Marlowe.Runtime.Types.Common
+      Language.Marlowe.Runtime.ContractCaching
       Language.Marlowe.Runtime.Types.ContractJSON
       Language.Marlowe.Runtime.Types.ContractsJSON
       Language.Marlowe.Runtime.Types.IndexedSeq
       Language.Marlowe.Runtime.Types.LazyFeed
+      Language.Marlowe.Runtime.Types.TransactionsJSON
       Language.Marlowe.Semantics.Types
       Lib
       Opts

src/Explorer/Web/ContractListView.hs

@@ -14,14 +14,14 @@ import Text.Printf ( printf )
 
 import Explorer.SharedContractCache ( ContractListCache, readContractList )
 import Explorer.Web.Util ( baseDoc, generateLink, table, td, th, tr, formatTimeDiff, makeLocalDateTime )
-import Language.Marlowe.Runtime.Types.ContractsJSON ( ContractInList (..), ContractLinks (..), Resource(..), ContractList (..) )
+import Language.Marlowe.Runtime.Types.ContractsJSON ( ContractInList (..), ContractLinks (..), Resource(..), ContractList (..), ContractInList (..) )
 import Opts (BlockExplorerHost(..), Options(optBlockExplorerHost))
-import Language.Marlowe.Runtime.Types.Common (Block(..))
 import Data.Foldable (toList)
 import Data.Maybe (fromMaybe)
 import qualified Data.Sequence as Seq
 import Data.List (intersperse)
 import qualified Language.Marlowe.Runtime.Types.IndexedSeq as ISeq
+import qualified Language.Marlowe.Runtime.Types.ContractsJSON as CSJ
 
 data PageInfo = PageInfo {
        currentPage :: Int
@@ -118,14 +118,14 @@ extractInfo timeNow blockExplHost mbPage (ContractList { clRetrievedTime = Just
     (minPage, maxPage) = calculateRange contextPages cPage lastPage
 
     convertContract :: ContractInList -> CIR
-    convertContract (ContractInList { links = ContractLinks { contract = cilLinkUrl }
-                                    , resource = Resource { block = Block { blockNo = cilBlockNo
-                                                                          , slotNo = cilSlotNo
-                                                                          }
-                                                          , contractId = cilContractId
-                                                          , roleTokenMintingPolicyId = cilRoleTokenMintingPolicyId
-                                                          }
-                                    }) = CIR
+    convertContract ContractInList { links = ContractLinks { contract = cilLinkUrl }
+                                   , resource = Resource { block = CSJ.Block { CSJ.blockNo = cilBlockNo
+                                                                             , CSJ.slotNo = cilSlotNo
+                                                                             }
+                                                         , contractId = cilContractId
+                                                         , roleTokenMintingPolicyId = cilRoleTokenMintingPolicyId
+                                                         }
+                                   } = CIR
       { clvrContractId = cilContractId
       , clvrBlock = cilBlockNo
       , clvrSlot = cilSlotNo
@@ -151,7 +151,6 @@ renderTime timeNow retrievalTime =
       p ! style "color: red" $ string (printf "The list of contracts could not be updated since " ++ formatTimeDiff difference ++ ", check the Marlowe Runtime is accessible")
     else p $ do string "Contracts list acquired: "
                 makeLocalDateTime retrievalTime
-
   where
     delayBeforeWarning :: NominalDiffTime
     delayBeforeWarning = 60  -- This is one minute

src/Explorer/Web/ContractView.hs

@@ -20,38 +20,29 @@ import Text.Printf (printf)
 import Explorer.Web.Util ( tr, th, td, table, baseDoc, mkNavLink, stringToHtml, prettyPrintAmount )
 import Language.Marlowe.Pretty ( pretty )
 import qualified Language.Marlowe.Runtime.Types.ContractJSON as CJ
-import Language.Marlowe.Runtime.Types.ContractJSON
-  ( ContractJSON(..), getContractJSON
-  , Transaction(..), Transactions(..), getContractTransactions
-  )
-import qualified Language.Marlowe.Runtime.Types.Common as Common
+import qualified Language.Marlowe.Runtime.Types.TransactionsJSON as TJ
 import Language.Marlowe.Semantics.Types (ChoiceId(..), Contract, Money,
   POSIXTime(..), Party(..), State(..), Token(..), ValueId(..))
 import Opts (Options, mkUrlPrefix)
 
-
 contractView :: Options -> Maybe String -> Maybe String -> IO ContractView
-
 contractView opts tab@(Just "txs") (Just cid) = do
   let urlPrefix = mkUrlPrefix opts
-  cjs <- getContractJSON urlPrefix cid
+  cjs <- CJ.getContractJSON urlPrefix cid
   case cjs of
     Left str -> pure $ ContractViewError str
     Right cjson -> do
-      let link = CJ.linkUrl . CJ.links $ cjson
-      etx <- getContractTransactions urlPrefix link
+      let link = CJ.transactions $ CJ.links cjson
+      etx <- TJ.getContractTransactions urlPrefix link
       pure $ case etx of
         Left str -> ContractViewError str
         Right tx -> extractInfo (parseTab tab) cjson (Just tx)
-
 contractView opts tab@(Just _) (Just cid) = do
-  cjs <- getContractJSON (mkUrlPrefix opts) cid
+  cjs <- CJ.getContractJSON (mkUrlPrefix opts) cid
   return $ case cjs of
     Left str -> ContractViewError str
     Right cjson -> extractInfo (parseTab tab) cjson Nothing
-
 contractView opts Nothing cid = contractView opts (Just "info") cid
-
 contractView _opts _tab Nothing = return $ ContractViewError "Need to specify a contractId"
 
 
@@ -61,21 +52,19 @@ parseTab (Just "txs") = CTxView
 parseTab _ = CInfoView
 
 
-extractInfo :: ContractViews -> ContractJSON -> Maybe Transactions -> ContractView
-
+extractInfo :: ContractViews -> CJ.ContractJSON -> Maybe TJ.Transactions -> ContractView
 extractInfo CInfoView cv _ =
   ContractInfoView
       (CIVR { civrContractId = CJ.contractId res
-            , blockHeaderHash = Common.blockHeaderHash block
-            , blockNo = Common.blockNo block
-            , slotNo = Common.slotNo block
+            , blockHeaderHash = CJ.blockHeaderHash block
+            , blockNo = CJ.blockNo block
+            , slotNo = CJ.slotNo block
             , roleTokenMintingPolicyId = CJ.roleTokenMintingPolicyId res
             , status = CJ.status res
             , version = CJ.version res
             })
   where res = CJ.resource cv
         block = CJ.block res
-
 extractInfo CStateView cv _ =
   ContractStateView
       (CSVR { csvrContractId = CJ.contractId res
@@ -84,18 +73,17 @@ extractInfo CStateView cv _ =
             , currentState = CJ.state res
             })
   where res = CJ.resource cv
-
-extractInfo CTxView cv (Just (Transactions txs)) =
-  ContractTxView . CTVRs (CJ.contractId . CJ.resource $ cv) . map convertTx $ txs
+extractInfo CTxView cv (Just (TJ.Transactions txs)) =
+  ContractTxView . CTVRs (CJ.contractId res) $ map convertTx txs
   where
-    convertTx tx = CTVR
-      { ctvrLink = CJ.linkUrl . txLink $ tx
-      , ctvrBlock = Common.blockNo . txBlock $ tx
-      , ctvrSlot = Common.slotNo . txBlock $ tx
-      , ctvrContractId = txContractId tx
-      , ctvrTransactionId = txTransactionId tx
-      }
-
+    res = CJ.resource cv
+    convertTx tx = CTVR { ctvrLink = TJ.transaction $ TJ.links tx
+                        , ctvrBlock = TJ.blockNo $ TJ.block tRes
+                        , ctvrSlot = TJ.slotNo $ TJ.block tRes
+                        , ctvrContractId = TJ.contractId tRes
+                        , ctvrTransactionId = TJ.transactionId tRes
+                        }
+      where tRes = TJ.resource tx
 extractInfo _ _ Nothing = ContractViewError "Something went wrong, unable to display"
 
 

src/Language/Marlowe/Runtime/Background.hs

@@ -7,13 +7,9 @@ module Language.Marlowe.Runtime.Background
 
 import Control.Concurrent ( forkIO, threadDelay, myThreadId )
 
-import Explorer.SharedContractCache
-  ( ContractListCache
-  , newContractList
-  , readContractList
-  , writeContractList
-  )
-import Language.Marlowe.Runtime.Types.ContractsJSON ( ContractList(..), refreshContracts )
+import Explorer.SharedContractCache ( ContractListCache, newContractList, readContractList, writeContractList )
+import Language.Marlowe.Runtime.ContractCaching (refreshContracts)
+import Language.Marlowe.Runtime.Types.ContractsJSON ( ContractList(..) )
 import qualified Language.Marlowe.Runtime.Types.IndexedSeq as ISeq
 import GHC.GHCi.Helpers (flushAll)
 import GHC.Conc (ThreadId)

src/Language/Marlowe/Runtime/ContractCaching.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.Marlowe.Runtime.ContractCaching (refreshContracts) where
+
+import Language.Marlowe.Runtime.Types.ContractsJSON ( Range(..), ContractList(..), ContractListISeq, ResultList(ResultList, results), ContractInList )
+import qualified Language.Marlowe.Runtime.Types.LazyFeed as LazyFeed
+import qualified Language.Marlowe.Runtime.Types.IndexedSeq as ISeq
+import Language.Marlowe.Runtime.Types.LazyFeed (LazyFeed)
+import Data.ByteString (ByteString)
+import Network.HTTP.Simple (HttpException, Request, parseRequest, setRequestHeader, setRequestMethod, httpLBS, getResponseBody, getResponseHeader)
+import Data.Time.Clock (getCurrentTime)
+import Data.Foldable (foldl')
+import Control.Exception (try, Exception (displayException))
+import Data.Aeson (eitherDecode)
+
+refreshContracts :: String -> ContractListISeq -> IO (Either String ContractList)
+refreshContracts endpoint lOldChain = do
+  eresult <- updateContracts endpoint lOldChain
+  now <- getCurrentTime
+  return $ do contracts <- eresult
+              return (ContractList { clRetrievedTime = Just now
+                                   , clContracts = contracts })
+
+updateContracts :: String -> ContractListISeq -> IO (Either String ContractListISeq)
+updateContracts endpoint oldContracts =
+  LazyFeed.foldThroughLazyFeed (completeOldContractList oldContracts) (getAllContracts endpoint)
+
+completeOldContractList :: ContractListISeq -> Maybe ContractInList
+                        -> Either ContractListISeq (ContractListISeq -> ContractListISeq)
+completeOldContractList oldList (Just h) =
+  case ISeq.findMatchingTail h oldList of
+    Just matchingTail -> Left matchingTail
+    Nothing -> Right $ ISeq.cons h
+completeOldContractList _ Nothing = Left ISeq.empty
+
+getAllContracts :: String -> LazyFeed ContractInList
+getAllContracts endpoint = getAllContracts' endpoint Start
+
+setRangeHeader :: Range -> Request -> Request
+setRangeHeader (Next bs) = setRequestHeader "Range" [bs]
+setRangeHeader _ = id
+
+parseRangeHeader :: [ByteString] -> Range
+parseRangeHeader [bs] = Next bs
+parseRangeHeader _ = Done
+
+getAllContracts' :: String -> Range -> LazyFeed ContractInList
+getAllContracts' _endpoint Done = LazyFeed.emptyLazyFeed
+getAllContracts' endpoint range = LazyFeed.fromIO $ do
+  initialRequest <- parseRequest $ endpoint <> "contracts"
+  let request = foldl' (flip id) initialRequest
+        [ setRequestMethod "GET"
+        , setRequestHeader "Accept" ["application/json"]
+        , setRangeHeader range
+        ]
+  mResponse <- try (httpLBS request)
+  case mResponse of
+    Right response -> do
+       case eitherDecode (getResponseBody response) of
+         Right (ResultList { results = contracts }) -> do
+           let nextRange = parseRangeHeader . getResponseHeader "Next-Range" $ response
+           return $ LazyFeed.prependListToLazyFeed contracts (getAllContracts' endpoint nextRange)
+         Left str2 -> return $ LazyFeed.errorToLazyFeed $ "Error decoding: " ++ str2
+    Left str -> return $ LazyFeed.errorToLazyFeed $ displayException (str :: HttpException)
+