Server.hs 19.4 KB
Newer Older
1
{-| Implementation of the Ganeti Query2 server.
2
3
4
5
6

-}

{-

7
Copyright (C) 2012, 2013, 2014 Google Inc.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

26
module Ganeti.Query.Server
27
28
29
  ( main
  , checkMain
  , prepMain
30
  ) where
31

32
import Control.Applicative
33
34
import Control.Concurrent
import Control.Exception
35
import Control.Monad (forever, when, zipWithM, liftM)
36
import Control.Monad.IO.Class
37
import Data.Bits (bitSize)
38
import qualified Data.Set as Set (toList)
39
import Data.IORef
Klaus Aehlig's avatar
Klaus Aehlig committed
40
import Data.Maybe (fromMaybe)
41
import qualified Text.JSON as J
42
import Text.JSON (encode, showJSON, JSValue(..))
43
import System.Info (arch)
Klaus Aehlig's avatar
Klaus Aehlig committed
44
import System.Directory
45
46

import qualified Ganeti.Constants as C
47
import qualified Ganeti.ConstantUtils as ConstantUtils (unFrozenSet)
48
import Ganeti.Errors
49
import qualified Ganeti.Path as Path
50
import Ganeti.Daemon
51
import Ganeti.Objects
52
import qualified Ganeti.Config as Config
53
import Ganeti.ConfigReader
54
import Ganeti.BasicTypes
Klaus Aehlig's avatar
Klaus Aehlig committed
55
import Ganeti.JQueue
Klaus Aehlig's avatar
Klaus Aehlig committed
56
import Ganeti.JQScheduler
57
import Ganeti.JSON (TimeAsDoubleJSON(..))
58
59
import Ganeti.Logging
import Ganeti.Luxi
60
import qualified Ganeti.Query.Language as Qlang
Thomas Thrainer's avatar
Thomas Thrainer committed
61
import qualified Ganeti.Query.Cluster as QCluster
62
63
import Ganeti.Path ( queueDir, jobQueueLockFile, jobQueueDrainFile
                   , defaultMasterSocket)
64
import Ganeti.Rpc
65
import Ganeti.Query.Query
66
import Ganeti.Query.Filter (makeSimpleFilter)
67
import Ganeti.Types
68
import qualified Ganeti.UDSServer as U (Handler(..), listener)
69
import Ganeti.Utils (lockFile, exitIfBad, watchFile, safeRenameFile)
70
import qualified Ganeti.Version as Version
71

Iustin Pop's avatar
Iustin Pop committed
72
73
74
-- | Helper for classic queries.
handleClassicQuery :: ConfigData      -- ^ Cluster config
                   -> Qlang.ItemType  -- ^ Query type
75
76
                   -> [Either String Integer] -- ^ Requested names
                                              -- (empty means all)
Iustin Pop's avatar
Iustin Pop committed
77
78
                   -> [String]        -- ^ Requested fields
                   -> Bool            -- ^ Whether to do sync queries or not
79
                   -> IO (GenericResult GanetiException JSValue)
80
handleClassicQuery _ _ _ _ True =
81
  return . Bad $ OpPrereqError "Sync queries are not allowed" ECodeInval
82
handleClassicQuery cfg qkind names fields _ = do
83
84
  let simpleNameFilter field = makeSimpleFilter (field qkind) names
      flt = Qlang.OrFilter $ map simpleNameFilter [nameField, uuidField]
Iustin Pop's avatar
Iustin Pop committed
85
86
87
  qr <- query cfg True (Qlang.Query qkind fields flt)
  return $ showJSON <$> (qr >>= queryCompat)

88
-- | Minimal wrapper to handle the missing config case.
Jose A. Lopes's avatar
Jose A. Lopes committed
89
handleCallWrapper :: MVar () -> JQStatus ->  Result ConfigData
Klaus Aehlig's avatar
Klaus Aehlig committed
90
                     -> LuxiOp -> IO (ErrorResult JSValue)
Klaus Aehlig's avatar
Klaus Aehlig committed
91
handleCallWrapper _ _ (Bad msg) _ =
92
93
94
  return . Bad . ConfigurationError $
           "I do not have access to a valid configuration, cannot\
           \ process queries: " ++ msg
Klaus Aehlig's avatar
Klaus Aehlig committed
95
handleCallWrapper qlock qstat (Ok config) op = handleCall qlock qstat config op
96
97

-- | Actual luxi operation handler.
Jose A. Lopes's avatar
Jose A. Lopes committed
98
handleCall :: MVar () -> JQStatus
Klaus Aehlig's avatar
Klaus Aehlig committed
99
100
              -> ConfigData -> LuxiOp -> IO (ErrorResult JSValue)
handleCall _ _ cdata QueryClusterInfo =
101
  let cluster = configCluster cdata
Thomas Thrainer's avatar
Thomas Thrainer committed
102
      master = QCluster.clusterMasterNodeName cdata
103
      hypervisors = clusterEnabledHypervisors cluster
104
      diskTemplates = clusterEnabledDiskTemplates cluster
105
106
107
      def_hv = case hypervisors of
                 x:_ -> showJSON x
                 [] -> JSNull
108
109
      bits = show (bitSize (0::Int)) ++ "bits"
      arch_tuple = [bits, arch]
Iustin Pop's avatar
Iustin Pop committed
110
111
112
      obj = [ ("software_version", showJSON C.releaseVersion)
            , ("protocol_version", showJSON C.protocolVersion)
            , ("config_version", showJSON C.configVersion)
113
114
115
            , ("os_api_version", showJSON . maximum .
                                 Set.toList . ConstantUtils.unFrozenSet $
                                 C.osApiVersions)
Iustin Pop's avatar
Iustin Pop committed
116
            , ("export_version", showJSON C.exportVersion)
117
            , ("vcs_version", showJSON Version.version)
Iustin Pop's avatar
Iustin Pop committed
118
            , ("architecture", showJSON arch_tuple)
119
            , ("name", showJSON $ clusterClusterName cluster)
Thomas Thrainer's avatar
Thomas Thrainer committed
120
121
122
            , ("master", showJSON (case master of
                                     Ok name -> name
                                     _ -> undefined))
123
            , ("default_hypervisor", def_hv)
Iustin Pop's avatar
Iustin Pop committed
124
            , ("enabled_hypervisors", showJSON hypervisors)
125
126
            , ("hvparams", showJSON $ clusterHvparams cluster)
            , ("os_hvp", showJSON $ clusterOsHvp cluster)
127
128
129
130
131
            , ("beparams", showJSON $ clusterBeparams cluster)
            , ("osparams", showJSON $ clusterOsparams cluster)
            , ("ipolicy", showJSON $ clusterIpolicy cluster)
            , ("nicparams", showJSON $ clusterNicparams cluster)
            , ("ndparams", showJSON $ clusterNdparams cluster)
132
            , ("diskparams", showJSON $ clusterDiskparams cluster)
133
134
            , ("candidate_pool_size",
               showJSON $ clusterCandidatePoolSize cluster)
Klaus Aehlig's avatar
Klaus Aehlig committed
135
136
            , ("max_running_jobs",
               showJSON $ clusterMaxRunningJobs cluster)
137
138
139
140
            , ("master_netdev",  showJSON $ clusterMasterNetdev cluster)
            , ("master_netmask", showJSON $ clusterMasterNetmask cluster)
            , ("use_external_mip_script",
               showJSON $ clusterUseExternalMipScript cluster)
141
142
            , ("volume_group_name",
               maybe JSNull showJSON (clusterVolumeGroupName cluster))
143
144
145
146
147
            , ("drbd_usermode_helper",
               maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster))
            , ("file_storage_dir", showJSON $ clusterFileStorageDir cluster)
            , ("shared_file_storage_dir",
               showJSON $ clusterSharedFileStorageDir cluster)
148
149
            , ("gluster_storage_dir",
               showJSON $ clusterGlusterStorageDir cluster)
150
151
            , ("maintain_node_health",
               showJSON $ clusterMaintainNodeHealth cluster)
152
153
            , ("ctime", showJSON . TimeAsDoubleJSON $ clusterCtime cluster)
            , ("mtime", showJSON . TimeAsDoubleJSON $ clusterMtime cluster)
154
155
156
157
158
            , ("uuid", showJSON $ clusterUuid cluster)
            , ("tags", showJSON $ clusterTags cluster)
            , ("uid_pool", showJSON $ clusterUidPool cluster)
            , ("default_iallocator",
               showJSON $ clusterDefaultIallocator cluster)
159
160
            , ("default_iallocator_params",
              showJSON $ clusterDefaultIallocatorParams cluster)
161
162
163
            , ("reserved_lvs", showJSON $ clusterReservedLvs cluster)
            , ("primary_ip_version",
               showJSON . ipFamilyToVersion $ clusterPrimaryIpFamily cluster)
164
165
166
167
            , ("prealloc_wipe_disks",
               showJSON $ clusterPreallocWipeDisks cluster)
            , ("hidden_os", showJSON $ clusterHiddenOs cluster)
            , ("blacklisted_os", showJSON $ clusterBlacklistedOs cluster)
168
            , ("enabled_disk_templates", showJSON diskTemplates)
169
170
            , ("instance_communication_network",
               showJSON (clusterInstanceCommunicationNetwork cluster))
171
172
            ]

Thomas Thrainer's avatar
Thomas Thrainer committed
173
174
175
  in case master of
    Ok _ -> return . Ok . J.makeObj $ obj
    Bad ex -> return $ Bad ex
176

Klaus Aehlig's avatar
Klaus Aehlig committed
177
handleCall _ _ cfg (QueryTags kind name) = do
178
  let tags = case kind of
179
               TagKindCluster  -> Ok . clusterTags $ configCluster cfg
180
181
182
183
               TagKindGroup    -> groupTags   <$> Config.getGroup    cfg name
               TagKindNode     -> nodeTags    <$> Config.getNode     cfg name
               TagKindInstance -> instTags    <$> Config.getInstance cfg name
               TagKindNetwork  -> networkTags <$> Config.getNetwork  cfg name
184
  return (J.showJSON <$> tags)
185

Klaus Aehlig's avatar
Klaus Aehlig committed
186
handleCall _ _ cfg (Query qkind qfields qfilter) = do
Agata Murawska's avatar
Agata Murawska committed
187
  result <- query cfg True (Qlang.Query qkind qfields qfilter)
188
189
  return $ J.showJSON <$> result

Klaus Aehlig's avatar
Klaus Aehlig committed
190
handleCall _ _ _ (QueryFields qkind qfields) = do
Iustin Pop's avatar
Iustin Pop committed
191
192
193
  let result = queryFields (Qlang.QueryFields qkind qfields)
  return $ J.showJSON <$> result

Klaus Aehlig's avatar
Klaus Aehlig committed
194
handleCall _ _ cfg (QueryNodes names fields lock) =
195
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNode)
196
    (map Left names) fields lock
Iustin Pop's avatar
Iustin Pop committed
197

Klaus Aehlig's avatar
Klaus Aehlig committed
198
handleCall _ _ cfg (QueryInstances names fields lock) =
199
200
201
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRInstance)
    (map Left names) fields lock

Klaus Aehlig's avatar
Klaus Aehlig committed
202
handleCall _ _ cfg (QueryGroups names fields lock) =
203
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRGroup)
204
    (map Left names) fields lock
Iustin Pop's avatar
Iustin Pop committed
205

Klaus Aehlig's avatar
Klaus Aehlig committed
206
handleCall _ _ cfg (QueryJobs names fields) =
207
  handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)
208
    (map (Right . fromIntegral . fromJobId) names)  fields False
209

Klaus Aehlig's avatar
Klaus Aehlig committed
210
handleCall _ _ cfg (QueryNetworks names fields lock) =
211
212
213
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNetwork)
    (map Left names) fields lock

Klaus Aehlig's avatar
Klaus Aehlig committed
214
215
216
217
218
219
220
handleCall _ _ cfg (QueryConfigValues fields) = do
  let params = [ ("cluster_name", return . showJSON . clusterClusterName
                                    . configCluster $ cfg)
               , ("watcher_pause", liftM (maybe JSNull showJSON)
                                     QCluster.isWatcherPaused)
               , ("master_node", return . genericResult (const JSNull) showJSON
                                   $ QCluster.clusterMasterNodeName cfg)
Klaus Aehlig's avatar
Klaus Aehlig committed
221
               , ("drain_flag", liftM (showJSON . not) isQueueOpen)
Klaus Aehlig's avatar
Klaus Aehlig committed
222
223
224
225
226
               ] :: [(String, IO JSValue)]
  let answer = map (fromMaybe (return JSNull) . flip lookup params) fields
  answerEval <- sequence answer
  return . Ok . showJSON $ answerEval

Klaus Aehlig's avatar
Klaus Aehlig committed
227
228
229
230
handleCall _ _ cfg (QueryExports nodes lock) =
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRExport)
    (map Left nodes) ["node", "export"] lock

231
handleCall qlock qstat cfg (SubmitJobToDrainedQueue ops) = runResultT $ do
232
    let mcs = Config.getMasterCandidates cfg
233
234
235
236
237
238
239
240
241
    jid <- mkResultT $ allocateJobId mcs qlock
    ts <- liftIO currentTimestamp
    job <- liftM (setReceivedTimestamp ts)
             $ queuedJobFromOpCodes jid ops
    qDir <- liftIO queueDir
    mkResultT $ writeJobToDisk qDir job
    liftIO $ replicateManyJobs qDir mcs [job]
    _ <- liftIO . forkIO $ enqueueNewJobs qstat [job]
    return . showJSON . fromJobId $ jid
Klaus Aehlig's avatar
Klaus Aehlig committed
242

Klaus Aehlig's avatar
Klaus Aehlig committed
243
handleCall qlock qstat cfg (SubmitJob ops) =
Klaus Aehlig's avatar
Klaus Aehlig committed
244
245
246
247
  do
    open <- isQueueOpen
    if not open
       then return . Bad . GenericError $ "Queue drained"
Klaus Aehlig's avatar
Klaus Aehlig committed
248
       else handleCall qlock qstat cfg (SubmitJobToDrainedQueue ops)
Klaus Aehlig's avatar
Klaus Aehlig committed
249

Klaus Aehlig's avatar
Klaus Aehlig committed
250
handleCall qlock qstat cfg (SubmitManyJobs lops) =
251
252
253
254
255
  do
    open <- isQueueOpen
    if not open
      then return . Bad . GenericError $ "Queue drained"
      else do
256
257
        let mcs = Config.getMasterCandidates cfg
        result_jobids <- allocateJobIds mcs qlock (length lops)
258
259
260
        case result_jobids of
          Bad s -> return . Bad . GenericError $ s
          Ok jids -> do
261
262
263
            ts <- currentTimestamp
            jobs <- liftM (map $ setReceivedTimestamp ts)
                      $ zipWithM queuedJobFromOpCodes jids lops
264
265
            qDir <- queueDir
            write_results <- mapM (writeJobToDisk qDir) jobs
266
            let annotated_results = zip write_results jobs
267
268
269
                succeeded = map snd $ filter (isOk . fst) annotated_results
            when (any isBad write_results) . logWarning
              $ "Writing some jobs failed " ++ show annotated_results
270
            replicateManyJobs qDir mcs succeeded
Klaus Aehlig's avatar
Klaus Aehlig committed
271
            _ <- forkIO $ enqueueNewJobs qstat succeeded
272
            return . Ok . JSArray
273
              . map (\(res, job) ->
274
                      if isOk res
275
                        then showJSON (True, fromJobId $ qjId job)
276
277
                        else showJSON (False, genericResult id (const "") res))
              $ annotated_results
278

279
handleCall _ _ cfg (WaitForJobChange jid fields prev_job prev_log tmout) = do
Jose A. Lopes's avatar
Jose A. Lopes committed
280
  let compute_fn = computeJobUpdate cfg jid fields prev_log
281
282
283
284
285
286
287
288
289
290
291
  qDir <- queueDir
  -- verify if the job is finalized, and return immediately in this case
  jobresult <- loadJobFromDisk qDir False jid
  case jobresult of
    Ok (job, _) | not (jobFinalized job) -> do
      let jobfile = liveJobFile qDir jid
      answer <- watchFile jobfile (min tmout C.luxiWfjcTimeout)
                  (prev_job, JSArray []) compute_fn
      return . Ok $ showJSON answer
    _ -> liftM (Ok . showJSON) compute_fn

292
293
294
295
296
297
handleCall _ _ cfg (SetWatcherPause time) = do
  let mcs = Config.getMasterCandidates cfg
      masters = genericResult (const []) return
                  . Config.getNode cfg . clusterMasterNode
                  $ configCluster cfg
  _ <- executeRpcCall (masters ++ mcs) $ RpcCallSetWatcherPause time
298
  return . Ok . maybe JSNull showJSON $ fmap TimeAsDoubleJSON time
299

Klaus Aehlig's avatar
Klaus Aehlig committed
300
301
302
303
304
305
306
307
308
handleCall _ _ cfg (SetDrainFlag value) = do
  let mcs = Config.getMasterCandidates cfg
  fpath <- jobQueueDrainFile
  if value
     then writeFile fpath ""
     else removeFile fpath
  _ <- executeRpcCall mcs $ RpcCallSetDrainFlag value
  return . Ok . showJSON $ True

309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
handleCall _ qstat cfg (ChangeJobPriority jid prio) = do
  maybeJob <- setJobPriority qstat jid prio
  case maybeJob of
    Bad s -> return . Ok $ showJSON (False, s)
    Ok (Just job) -> runResultT $ do
      let mcs = Config.getMasterCandidates cfg
      qDir <- liftIO queueDir
      liftIO $ replicateManyJobs qDir mcs [job]
      return $ showJSON (True, "Priorities of pending opcodes for job "
                               ++ show (fromJobId jid) ++ " have been changed"
                               ++ " to " ++ show prio)
    Ok Nothing -> runResultT $ do
      -- Job has already started; so we have to forward the request
      -- to the job, currently handled by masterd.
      socketpath <- liftIO defaultMasterSocket
      cl <- liftIO $ getLuxiClient socketpath
      ResultT $ callMethod (ChangeJobPriority jid prio) cl

327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
handleCall _ qstat  cfg (CancelJob jid) = do
  let jName = (++) "job " . show $ fromJobId jid
  dequeueResult <- dequeueJob qstat jid
  case dequeueResult of
    Ok True -> do
      logDebug $ jName ++ " dequeued, marking as canceled"
      qDir <- queueDir
      readResult <- loadJobFromDisk qDir True jid
      let jobFileFailed = return . Ok . showJSON . (,) False
                            . (++) ("Dequeued " ++ jName
                                    ++ ", but failed to mark as cancelled: ")
                          :: String -> IO (ErrorResult JSValue)
      case readResult of
        Bad s -> jobFileFailed s
        Ok (job, _) -> do
          now <- currentTimestamp
          let job' = cancelQueuedJob now job
              mcs = Config.getMasterCandidates cfg
          write_result <- writeJobToDisk qDir job'
          case write_result of
            Bad s -> jobFileFailed s
            Ok () -> do
              replicateManyJobs qDir mcs [job']
              return . Ok . showJSON $ (True, "Dequeued " ++ jName)
    Ok False -> do
      logDebug $ jName ++ " not queued; trying to cancel directly"
      cancelJob jid
    Bad s -> return . Ok . showJSON $ (False, s)

356
357
358
359
360
361
362
363
364
365
366
367
368
handleCall qlock _ cfg (ArchiveJob jid) = do
  let archiveFailed = putMVar qlock  () >> (return . Ok $ showJSON False)
                      :: IO (ErrorResult JSValue)
  qDir <- queueDir
  takeMVar qlock
  result <- loadJobFromDisk qDir False jid
  case result of
    Bad _ -> archiveFailed
    Ok (job, _) -> if jobFinalized job
                     then do
                       let mcs = Config.getMasterCandidates cfg
                           live = liveJobFile qDir jid
                           archive = archivedJobFile qDir jid
369
370
                       renameResult <- safeRenameFile queueDirPermissions
                                         live archive
371
372
                       putMVar qlock ()
                       case renameResult of
373
374
375
376
                         Bad s -> return . Bad . JobQueueError
                                    $ "Archiving failed in an unexpected way: "
                                        ++ s
                         Ok () -> do
377
378
                           _ <- executeRpcCall mcs
                                  $ RpcCallJobqueueRename [(live, archive)]
379
                           return . Ok $ showJSON True
380
381
                     else archiveFailed

382
383
handleCall qlock _ cfg (AutoArchiveJobs age timeout) = do
  qDir <- queueDir
384
385
386
387
  resultJids <- getJobIDs [qDir]
  case resultJids of
    Bad s -> return . Bad . JobQueueError $ show s
    Ok jids -> do
388
389
390
391
392
      result <- bracket_ (takeMVar qlock) (putMVar qlock ())
                  . archiveJobs cfg age timeout
                  $ sortJobIDs jids
      return . Ok $ showJSON result

393
394
395
handleCall _ _ _ (PickupJob _) =
  return . Bad
    $ GenericError "Luxi call 'PickupJob' is for internal use only"
396

397
398
{-# ANN handleCall "HLint: ignore Too strict if" #-}

399
400
-- | Query the status of a job and return the requested fields
-- and the logs newer than the given log number.
Jose A. Lopes's avatar
Jose A. Lopes committed
401
computeJobUpdate :: ConfigData -> JobId -> [String] -> JSValue
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
                    -> IO (JSValue, JSValue)
computeJobUpdate cfg jid fields prev_log = do
  let sjid = show $ fromJobId jid
  logDebug $ "Inspecting fields " ++ show fields ++ " of job " ++ sjid
  let fromJSArray (JSArray xs) = xs
      fromJSArray _ = []
  let logFilter JSNull (JSArray _) = True
      logFilter (JSRational _ n) (JSArray (JSRational _ m:_)) = n < m
      logFilter _ _ = False
  let filterLogs n logs = JSArray (filter (logFilter n) (logs >>= fromJSArray))
  jobQuery <- handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)
                [Right . fromIntegral $ fromJobId jid] ("oplog" : fields) False
  let (rfields, rlogs) = case jobQuery of
        Ok (JSArray [JSArray (JSArray logs : answer)]) ->
          (answer, filterLogs prev_log logs)
        _ -> (map (const JSNull) fields, JSArray [])
  logDebug $ "Updates for job " ++ sjid ++ " are " ++ encode (rfields, rlogs)
  return (JSArray rfields, rlogs)

421
422
423
424
425
426
427
428

type LuxiConfig = (MVar (), JQStatus, ConfigReader)

luxiExec
    :: LuxiConfig
    -> LuxiOp
    -> IO (Bool, GenericResult GanetiException JSValue)
luxiExec (qlock, qstat, creader) args = do
429
  cfg <- creader
430
431
432
433
434
435
436
437
438
439
  result <- handleCallWrapper qlock qstat cfg args
  return (True, result)

luxiHandler :: LuxiConfig -> U.Handler LuxiOp JSValue
luxiHandler cfg = U.Handler { U.hParse         = decodeLuxiCall
                            , U.hInputLogShort = strOfOp
                            , U.hInputLogLong  = show
                            , U.hExec          = luxiExec cfg
                            }

440
-- | Type alias for prepMain results
441
type PrepResult = (Server, IORef (Result ConfigData), JQStatus)
442

Thomas Thrainer's avatar
Thomas Thrainer committed
443
-- | Check function for luxid.
444
445
446
checkMain :: CheckFn ()
checkMain _ = return $ Right ()

Thomas Thrainer's avatar
Thomas Thrainer committed
447
-- | Prepare function for luxid.
448
449
450
prepMain :: PrepFn () PrepResult
prepMain _ _ = do
  socket_path <- Path.defaultQuerySocket
451
  cleanupSocket socket_path
452
  s <- describeError "binding to the Luxi socket"
453
         Nothing (Just socket_path) $ getLuxiServer True socket_path
454
  cref <- newIORef (Bad "Configuration not yet loaded")
455
  jq <- emptyJQStatus cref
456
  return (s, cref, jq)
457
458
459

-- | Main function.
main :: MainFn () PrepResult
460
main _ _ (server, cref, jq) = do
461
462
  initConfigReader id cref
  let creader = readIORef cref
Klaus Aehlig's avatar
Klaus Aehlig committed
463
  initJQScheduler jq
Jose A. Lopes's avatar
Jose A. Lopes committed
464

Klaus Aehlig's avatar
Klaus Aehlig committed
465
466
467
  qlockFile <- jobQueueLockFile
  lockFile qlockFile >>= exitIfBad "Failed to obtain the job-queue lock"
  qlock <- newMVar ()
468
469

  finally
470
    (forever $ U.listener (luxiHandler (qlock, jq, creader)) server)
471
    (closeServer server)