Skip to content

Commit 813cee9

Browse files
imalsogregimalsogreg
committed
Get working with more uniform EntityID
1 parent 61c0f0f commit 813cee9

File tree

14 files changed

+104
-142
lines changed

14 files changed

+104
-142
lines changed

‎.ghci

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
:set +c
21
:set -isrc -itest
32
import Data.Proxy
43
import Servant.Matlab

‎snaplets/heist/templates/_job_requester.tpl

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,7 @@
66
<input type="text"
77
placeholder="reverse" id="fun-name"/>
88
<input type="text"
9-
placeholder="Hello" id="fun-args"/>
9+
placeholder="Hello" id="fun-arg"/>
1010
<button class="btn btn-default"
1111
type="button" id="call-button"
1212
onclick="callFun()">Call</button>

‎src/API.hs

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -31,10 +31,10 @@ import Job
3131
-- For more information about API specifications, see the Servant
3232
-- <http://haskell-servant.github.io documentation>
3333
type API1 = "user" :> UserAPI
34-
:<|> "worker" :> Get '[JSON] WorkerMap
35-
:<|> "callfun" :> QueryParam "worker-id" WorkerID
36-
:> QueryParam "browser-id" BrowserID
37-
:> ReqBody '[JSON] Job :> Post '[JSON] JobID
34+
:<|> "worker" :> Get '[JSON] WorkerProfileMap
35+
:<|> "callfun" :> QueryParam "worker-id" (EntityID WorkerProfile)
36+
:> QueryParam "browser-id" (EntityID Browser)
37+
:> ReqBody '[JSON] Job :> Post '[JSON] (EntityID Job)
3838

3939

4040
------------------------------------------------------------------------------

‎src/Browser.hs

Lines changed: 3 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -14,38 +14,14 @@ import Data.UUID.V4
1414
import qualified Network.WebSockets as WS
1515
import qualified Servant.API as Servant
1616
import Web.HttpApiData
17-
18-
-- import Worker
17+
import EntityID
1918
import Job
2019

2120
data Browser = Browser
22-
{ bID :: BrowserID
21+
{ bID :: EntityID Browser
2322
, bConn :: WS.Connection
2423
, bJobResults :: TChan JobResult
2524
}
2625

27-
newtype BrowserID = BrowserID { unBrowserID :: UUID }
28-
deriving (Eq, Ord, Show)
29-
30-
newtype BrowserMap = BrowserMap { unBrowserMap :: Map.Map BrowserID Browser }
31-
32-
instance A.ToJSON BrowserID where
33-
toJSON (BrowserID u) = A.String (toText u)
34-
35-
instance A.FromJSON BrowserID where
36-
parseJSON (A.String s) = case fromText s of
37-
Nothing -> mzero
38-
Just u -> return $ BrowserID u
39-
parseJSON _ = mzero
40-
41-
instance FromHttpApiData BrowserID where
42-
parseUrlPiece s = BrowserID <$> Browser.note "Bad UUID parse" (fromText s)
43-
44-
instance ToHttpApiData BrowserID where
45-
toUrlPiece (BrowserID u) = toText u
46-
47-
note :: e -> Maybe a -> Either e a
48-
note e Nothing = Left e
49-
note _ (Just a) = Right a
50-
26+
type BrowserMap = EntityMap Browser
5127

‎src/EntityID.hs

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,21 @@
11
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE DeriveGeneric #-}
3+
24

35
module EntityID where
46

57
import Control.Monad (mzero)
68
import qualified Data.Aeson as A
79
import Data.Aeson (FromJSON, ToJSON)
10+
import qualified Data.Map as Map
811
import Data.Monoid
912
import Data.Text (unpack)
1013
import qualified Data.UUID as UUID
1114
import Database.PostgreSQL.Simple.ToField
1215
import Database.PostgreSQL.Simple.FromField
1316
import Database.PostgreSQL.Simple.FromRow
1417
import Database.PostgreSQL.Simple.ToRow
18+
import GHC.Generics
1519
import Servant.API
1620
import Web.HttpApiData
1721

@@ -21,6 +25,12 @@ import Web.HttpApiData
2125
newtype EntityID a = EntityID { unID :: UUID.UUID }
2226
deriving (Show, Read, Eq, Ord)
2327

28+
newtype EntityMap a = EntityMap { unEntityMap :: Map.Map (EntityID a) a }
29+
deriving (Eq, Ord, Generic)
30+
31+
instance ToJSON a => ToJSON (EntityMap a) where
32+
toJSON (EntityMap m) = A.toJSON (Map.mapKeys (UUID.toText . unID) m)
33+
2434

2535
------------------------------------------------------------------------------
2636
-- | Convert an ID to JSON. Construct a JSON String value from the

‎src/Job.hs

Lines changed: 3 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -13,29 +13,11 @@ import Data.Text
1313
import Data.UUID
1414
import qualified Data.UUID as UUID
1515
import Web.HttpApiData
16+
import EntityID
1617

1718
import Model
1819

19-
newtype JobID = JobID { _unJobID :: UUID }
20-
deriving (Eq, Show, Ord)
21-
22-
instance ToJSON JobID where
23-
toJSON (JobID uu) = String $ UUID.toText uu
24-
25-
instance FromJSON JobID where
26-
parseJSON (String s) = maybe mzero (return . JobID) (UUID.fromText s)
27-
parseJSON _ = mzero
28-
29-
instance FromHttpApiData JobID where
30-
parseUrlPiece t = JobID <$> note "Bad UUID decode" (UUID.fromText t)
31-
note :: e -> Maybe a -> Either e a
32-
note e Nothing = Left e
33-
note _ (Just a) = Right a
34-
35-
instance ToHttpApiData JobID where
36-
toUrlPiece (JobID u) = UUID.toText u
37-
38-
makeLenses ''JobID
20+
type JobMap = EntityMap Job
3921

4022
data Job = Job
4123
{ -- _jID :: JobID
@@ -60,7 +42,7 @@ instance FromJSON Job where
6042
data JobResult = JobResult
6143
{ jrVal :: Model.Val
6244
-- , jrWorker :: WorkerID
63-
, jrJob :: JobID
45+
, jrJob :: EntityID Job
6446
} deriving (Eq, Show)
6547

6648
instance ToJSON JobResult where

‎src/Message.hs

Lines changed: 12 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -6,23 +6,24 @@ module Message where
66
import qualified Data.Aeson as A
77
import GHC.Generics
88
------------------------------------------------------------------------------
9+
import EntityID
910
import Browser
1011
import Job
1112
import Worker
1213

1314
------------------------------------------------------------------------------
1415
-- | 'BrowserMessage's go between browser and CBaaS server
15-
data BrowserMessage = WorkerJoined WorkerID WorkerProfile
16+
data BrowserMessage = WorkerJoined (EntityID WorkerProfile) WorkerProfile
1617
-- ^ Informing the browser that a worker has joined
17-
| WorkerLeft WorkerID
18+
| WorkerLeft (EntityID WorkerProfile)
1819
-- ^ Informing the browser that a worker has left
19-
| JobFinished (JobID, JobResult)
20+
| JobFinished (EntityID Job, JobResult)
2021
-- ^ Informing the browser of job completion - usually
2122
-- for jobs that this browser requested
22-
| JobStatusUpdate (JobID, JobResult)
23+
| JobStatusUpdate (EntityID Job, JobResult)
2324
-- ^ Informing the browser of a status-update on a
2425
-- job
25-
| SetBrowserID BrowserID
26+
| SetBrowserID (EntityID Browser)
2627
-- ^ Inform the browser of its ID number
2728
-- TODO: should this be asynchronous information?
2829
-- TODO: Does it need to be validated or enforced
@@ -34,23 +35,25 @@ instance A.FromJSON BrowserMessage
3435

3536
------------------------------------------------------------------------------
3637
-- | 'WorkerMessage's go between CBaaS server and online workers
37-
data WorkerMessage = JobRequested (JobID, Maybe BrowserID, Job)
38+
data WorkerMessage = JobRequested
39+
(EntityID Job, Maybe (EntityID Browser), Job)
3840
-- ^ Informs a worker that a user has requested a job.
3941
-- CBaaS server is
4042
-- responsible for ensuring that job requests are
4143
-- filtered by function name, argument type,
4244
-- and the worker's willingness to do jobs for
4345
-- various sorts of users based on group membership
44-
| WorkerStatusUpdate (JobID, Maybe BrowserID, JobResult)
46+
| WorkerStatusUpdate
47+
(EntityID Job, Maybe (EntityID Browser), JobResult)
4548
-- ^ Informs the server that partial progress has been
4649
-- made on a job.
4750
-- TODO: Can/should we enforce the type
4851
-- of incremental results?
49-
| WorkerFinished (JobID, Maybe BrowserID, JobResult)
52+
| WorkerFinished
53+
(EntityID Job, Maybe (EntityID Browser), JobResult)
5054
-- ^ Informs the server that the worker has finished,
5155
-- including the 'JobResult' data
5256
deriving (Eq, Show, Generic)
5357

5458
instance A.ToJSON WorkerMessage
5559
instance A.FromJSON WorkerMessage
56-

‎src/Server/APIServer.hs

Lines changed: 12 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -41,7 +41,7 @@ import Job
4141
-- | Top-level API server implementation
4242
serverAPI :: Server API1 AppHandler
4343
serverAPI = serverAuth
44-
:<|> listWorkers
44+
:<|> listOnlineWorkers
4545
:<|> callfun
4646

4747

@@ -94,23 +94,22 @@ crudServer p =
9494

9595
in getAll :<|> get :<|> post :<|> put :<|> delete
9696

97-
listWorkers :: Server (Get '[JSON] WorkerMap) AppHandler
98-
listWorkers = do
97+
listOnlineWorkers :: Server (Get '[JSON] WorkerProfileMap) AppHandler
98+
listOnlineWorkers = do
9999
wrks <- liftIO . atomically . readTVar =<< gets _workers
100-
return (WorkerMap $ Map.map _wProfile wrks)
100+
return (EntityMap $ Map.map _wProfile wrks)
101101

102102
callfun
103-
:: Server (QueryParam "worker-id" WorkerID
104-
:> QueryParam "browser-id" BrowserID
103+
:: Server (QueryParam "worker-id" (EntityID WorkerProfile)
104+
:> QueryParam "browser-id" (EntityID Browser)
105105
:> ReqBody '[JSON] Job
106-
:> Post '[JSON] JobID) AppHandler
107-
callfun (Just wID) bID job = do
108-
wrks <- liftIO . atomically . readTVar =<< gets _workers
109-
liftIO (print $ Map.map _wProfile wrks)
106+
:> Post '[JSON] (EntityID Job)) AppHandler
107+
callfun (Just wID :: Maybe (EntityID WorkerProfile)) bID job = do
108+
wrks :: Map.Map (EntityID WorkerProfile) Worker <- liftIO . atomically . readTVar =<< gets _workers
110109
case Map.lookup wID wrks of
111-
Nothing -> liftIO (print "No match") >> pass
112-
Just w -> do
113-
jID <- JobID <$> liftIO nextRandom
110+
Nothing -> liftIO (print "No match") >> pass
111+
(Just w :: Maybe Worker) -> do
112+
jID <- EntityID <$> liftIO nextRandom
114113
liftIO $ atomically $ writeTChan (_wJobQueue w) (jID, bID, job)
115114
return jID
116115

‎src/Server/Application.hs

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ import Snap.Snaplet.Auth
1818
import Snap.Snaplet.PostgresqlSimple
1919
import Snap.Snaplet.Session
2020

21+
import EntityID
2122
import Combo
2223
import Worker
2324
import Browser
@@ -30,10 +31,10 @@ data App = App
3031
, _db :: Snaplet Postgres
3132
, _sess :: Snaplet SessionManager
3233
, _auth :: Snaplet (AuthManager App)
33-
, _workers :: TVar (Map WorkerID Worker)
34-
, _browsers :: TVar (Map BrowserID Browser)
35-
, _jqueue :: TChan (WorkerID, JobID, Model.Val)
36-
, _rqueue :: TChan (WorkerID, JobID, Model.Val)
34+
, _workers :: TVar (Map (EntityID WorkerProfile) Worker)
35+
, _browsers :: TVar BrowserMap
36+
, _jqueue :: TChan (EntityID Worker, EntityID Job, Model.Val)
37+
, _rqueue :: TChan (EntityID Worker, EntityID Job, Model.Val)
3738
-- , _combo :: Snaplet ComboState -- TODO: having trouble
3839
-- with SnapletInit here
3940
}

‎src/Server/Site.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ import qualified Heist.Interpreted as I
3636
------------------------------------------------------------------------------
3737
import API
3838
-- import Combo
39+
import EntityID
3940
import Server.Application
4041
import Server.APIServer
4142
import WebSocketServer
@@ -99,8 +100,8 @@ app = makeSnaplet "app" "An snaplet example application." Nothing $ do
99100
initCookieSessionManager "site_key.txt" "sess" Nothing (Just 3600)
100101
a <- nestSnaplet "auth" auth $
101102
initPostgresAuth sess p
102-
w <- liftIO $ newTVarIO Data.Map.empty
103-
b <- liftIO $ newTVarIO Data.Map.empty
103+
w <- liftIO $ newTVarIO $ Data.Map.empty
104+
b <- liftIO $ newTVarIO $ EntityMap Data.Map.empty
104105
j <- liftIO newBroadcastTChanIO
105106
r <- liftIO newBroadcastTChanIO
106107
addRoutes routes

0 commit comments

Comments
 (0)