1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
|
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
module Thermoprint.Server.API
( ProtoHandler, Handler
, thermoprintServer
, handlerNat
) where
import Thermoprint.API hiding (JobId(..), DraftId(..))
import qualified Thermoprint.API as API (JobId(..), DraftId(..))
import Thermoprint.Server.Printer
import Thermoprint.Server.Queue
import Thermoprint.Server.Database
import Thermoprint.Server.Push
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Text as T
import Servant hiding (Handler)
import Servant.Server hiding (Handler)
import qualified Servant.Server as Servant (Handler(..))
import Servant.Utils.Enter
import Servant.Utils.Links
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Concurrent.STM
import Control.Monad ((<=<), liftM2)
import Prelude hiding ((.), id, mapM)
import Control.Category
import Control.DeepSeq
import Data.Foldable (toList)
import Data.Traversable (mapM)
import Data.Bifunctor
import Data.Monoid
import Data.Maybe
import Data.Function (on)
import Database.Persist
import Database.Persist.Sql
import Data.Conduit (Source, sourceToList, mapOutput)
import Data.Acquire (with)
import Control.Monad.Catch (handle, catch)
import Data.Time
type ProtoHandler = ReaderT HandlerInput (LoggingT (ResourceT IO))
type Handler = ExceptT ServantErr ProtoHandler
-- ^ Runtime configuration of our handlers
data HandlerInput = HandlerInput { sqlPool :: ConnectionPool -- ^ How to interact with 'persistent' storage
, printers :: Map PrinterId Printer
, nChan :: TChan Notification
}
handlerNat :: ( MonadReader ConnectionPool m
, MonadLoggerIO m
) => Map PrinterId Printer -> TChan Notification -> m (Handler :~> Servant.Handler)
-- ^ Servant requires its handlers to be essentially 'ExceptT ServantErr IO'
--
-- This generates a 'Nat'ural transformation for squashing the monad-transformer-stack we use in our handlers to the monad 'servant-server' wants
handlerNat printerMap nChan = do
sqlPool <- ask
logFunc <- askLoggerIO
let
handlerInput = HandlerInput
{ sqlPool = sqlPool
, printers = printerMap
, nChan = nChan
}
protoNat :: ProtoHandler :~> IO
protoNat = NT runResourceT . NT (($ logFunc) . runLoggingT) . runReaderTNat handlerInput
return $ NT Servant.Handler . hoistNat protoNat
runSql :: ReaderT SqlBackend ProtoHandler a -> Handler a
runSql act = lift $ runSqlPool act =<< asks sqlPool
thermoprintServer :: ServerT ThermoprintAPI Handler
-- ^ A 'servant-server' for 'ThermoprintAPI'
thermoprintServer = listPrinters
:<|> (listJobs :<|> queueJob)
:<|> getJob <||> jobStatus <||> abortJob
:<|> (listDrafts :<|> addDraft)
:<|> updateDraft <||> getDraft <||> deleteDraft <||> printDraft
where
-- :: (a -> b) -> (a -> c) -> (a -> b :<|> c)
(<||>) :: Monad m => m a -> m b -> m (a :<|> b)
(<||>) = liftM2 (:<|>)
infixr 9 <||>
notify :: Notification -> Handler ()
notify n = liftIO . atomically =<< flip writeTChan n <$> asks nChan
lookupPrinter :: Maybe PrinterId -> Handler (PrinterId, Printer)
-- ^ Make sure a printer exists
lookupPrinter pId = asks printers >>= maybePrinter' pId
where
maybePrinter' Nothing printerMap
| Map.null printerMap = throwError $ err501 { errBody = "No printers available" }
| otherwise = return $ Map.findMin printerMap
maybePrinter' (Just pId) printerMap
| Just printer <- Map.lookup pId printerMap = return (pId, printer)
| otherwise = throwError $ err404 { errBody = "No such printer" }
queue' :: MonadIO m => Printer -> m Queue
-- ^ Call 'queue' and handle concurrency
queue' = fmap force . liftIO . readTVarIO . queue
extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, UTCTime, JobStatus)
-- ^ Get an API-compatible list of all jobs from a 'Printer' 'Queue'
extractJobs (pId, Queue pending current history) = mconcat [ fmap (\e -> (castId $ jobId e, created e, Queued pId)) pending
, maybe Seq.empty Seq.singleton $ fmap (\e -> (castId $ jobId e, created e, Printing pId)) current
, fmap (\(e, s) -> (castId $ jobId e, created e, maybe Done Failed $ s)) history
]
listPrinters :: Handler (Map PrinterId PrinterStatus)
listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers =<< ask)
where
toStatus (Queue _ Nothing _) = Available
toStatus (Queue _ (Just id) _) = Busy . castId $ jobId id
queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId
queueJob pId printout = lift . fmap castId . withReaderT sqlPool . addToQueue printout . snd =<< lookupPrinter pId
printerStatus :: PrinterId -> Handler PrinterStatus
printerStatus = fmap queueToStatus . queue' . snd <=< lookupPrinter . Just
where
queueToStatus (Queue _ Nothing _) = Available
queueToStatus (Queue _ (Just c) _) = Busy . castId $ jobId c
listJobs :: Maybe PrinterId
-> Maybe (Range API.JobId) -> Maybe (Range UTCTime)
-> Handler (Seq (API.JobId, UTCTime, JobStatus))
listJobs Nothing idR timeR = fmap mconcat . mapM (\pId -> listJobs (Just pId) idR timeR) =<< asks (Map.keys . printers)
listJobs pId idR timeR = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a <$> queue' b) =<< lookupPrinter pId
where
filterJobs = Seq.filter (\(id, time, _) -> and ([ maybe True (`contains` id) idR
, maybe True (`contains` time) timeR
] :: [Bool])
)
getJob :: API.JobId -> Handler Printout
getJob jobId = fmap jobContent . maybe (throwError err404) return =<< runSql (get $ castId jobId)
jobStatus :: API.JobId -> Handler JobStatus
jobStatus jobId = maybe (throwError err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing
abortJob :: API.JobId -> Handler ()
abortJob needle = do
printerIds <- asks (Map.keys . printers)
found <- fmap or . forM printerIds $ \pId -> do
(pId', p) <- lookupPrinter $ Just pId
found <- liftIO . atomically $ do
current@(Queue pending _ _) <- readTVar $ queue p
let filtered = Seq.filter ((/= castId needle) . jobId) pending
writeTVar (queue p) $ current { pending = filtered }
return . not $ ((==) `on` length) pending filtered
when found $ do
$(logInfo) $ "Removed job #" <> (T.pack $ show (castId needle :: Integer)) <> " from " <> (T.pack . show $ pId')
notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus))))
return found
when (not found) $ throwError err404
listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle))
listDrafts = runSql (selectSourceRes [] []) >>= lift . flip with toMap
where
toMap source = fmap Map.fromList . sourceToList $ (\(Entity key (Draft title _)) -> (castId key, title)) `mapOutput` source
addDraft :: Maybe DraftTitle -> Printout -> Handler API.DraftId
addDraft title content = do
id <- castId <$> runSql (insert $ Draft title content)
$(logInfo) $ "Added draft #" <> (T.pack $ show (castId id :: Integer)) <> " (" <> (T.pack $ show title) <> ")"
notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle))))
return id
updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler ()
updateDraft draftId title content = handle (\(KeyNotFound _) -> throwError $ err404) $ do
void . runSql $ updateGet (castId draftId) [ DraftTitle =. title, DraftContent =. content ]
$(logInfo) $ "Updated draft #" <> (T.pack $ show (castId draftId :: Integer))
notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId
getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout)
getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (throwError err404) return =<< runSql (get $ castId draftId)
deleteDraft :: API.DraftId -> Handler ()
deleteDraft draftId = do
runSql $ delete (castId draftId :: Key Draft)
$(logInfo) $ "Made sure draft #" <> (T.pack $ show (castId draftId :: Integer)) <> " is Deleted"
notify . linkURI $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle))))
printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId
printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (throwError err404) return =<< runSql (get $ castId draftId)
|
