Server.hs 19.6 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
Klaus Aehlig's avatar
Klaus Aehlig committed
45
import System.Posix.Signals as P
46
47

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

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

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

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

Thomas Thrainer's avatar
Thomas Thrainer committed
178
179
180
  in case master of
    Ok _ -> return . Ok . J.makeObj $ obj
    Bad ex -> return $ Bad ex
181

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

Klaus Aehlig's avatar
Klaus Aehlig committed
191
handleCall _ _ cfg (Query qkind qfields qfilter) = do
Agata Murawska's avatar
Agata Murawska committed
192
  result <- query cfg True (Qlang.Query qkind qfields qfilter)
193
194
  return $ J.showJSON <$> result

Klaus Aehlig's avatar
Klaus Aehlig committed
195
handleCall _ _ _ (QueryFields qkind qfields) = do
Iustin Pop's avatar
Iustin Pop committed
196
197
198
  let result = queryFields (Qlang.QueryFields qkind qfields)
  return $ J.showJSON <$> result

Klaus Aehlig's avatar
Klaus Aehlig committed
199
handleCall _ _ cfg (QueryNodes names fields lock) =
200
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNode)
201
    (map Left names) fields lock
Iustin Pop's avatar
Iustin Pop committed
202

Klaus Aehlig's avatar
Klaus Aehlig committed
203
handleCall _ _ cfg (QueryInstances names fields lock) =
204
205
206
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRInstance)
    (map Left names) fields lock

Klaus Aehlig's avatar
Klaus Aehlig committed
207
handleCall _ _ cfg (QueryGroups names fields lock) =
208
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRGroup)
209
    (map Left names) fields lock
Iustin Pop's avatar
Iustin Pop committed
210

Klaus Aehlig's avatar
Klaus Aehlig committed
211
handleCall _ _ cfg (QueryJobs names fields) =
212
  handleClassicQuery cfg (Qlang.ItemTypeLuxi Qlang.QRJob)
213
    (map (Right . fromIntegral . fromJobId) names)  fields False
214

Klaus Aehlig's avatar
Klaus Aehlig committed
215
handleCall _ _ cfg (QueryNetworks names fields lock) =
216
217
218
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRNetwork)
    (map Left names) fields lock

Klaus Aehlig's avatar
Klaus Aehlig committed
219
220
221
222
223
224
225
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
226
               , ("drain_flag", liftM (showJSON . not) isQueueOpen)
Klaus Aehlig's avatar
Klaus Aehlig committed
227
228
229
230
231
               ] :: [(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
232
233
234
235
handleCall _ _ cfg (QueryExports nodes lock) =
  handleClassicQuery cfg (Qlang.ItemTypeOpCode Qlang.QRExport)
    (map Left nodes) ["node", "export"] lock

236
handleCall qlock qstat cfg (SubmitJobToDrainedQueue ops) = runResultT $ do
237
    jid <- mkResultT $ allocateJobId (Config.getMasterCandidates cfg) qlock
238
    ts <- liftIO currentTimestamp
239
    job <- liftM (extendJobReasonTrail . setReceivedTimestamp ts)
240
241
             $ queuedJobFromOpCodes jid ops
    qDir <- liftIO queueDir
242
    _ <- writeAndReplicateJob cfg qDir job
243
244
    _ <- liftIO . forkIO $ enqueueNewJobs qstat [job]
    return . showJSON . fromJobId $ jid
Klaus Aehlig's avatar
Klaus Aehlig committed
245

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

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

282
handleCall _ _ cfg (WaitForJobChange jid fields prev_job prev_log tmout) = do
Jose A. Lopes's avatar
Jose A. Lopes committed
283
  let compute_fn = computeJobUpdate cfg jid fields prev_log
284
285
286
287
  qDir <- queueDir
  -- verify if the job is finalized, and return immediately in this case
  jobresult <- loadJobFromDisk qDir False jid
  case jobresult of
288
    Bad s -> return . Bad $ JobLost s
289
290
291
292
293
294
295
    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

296
297
298
299
300
301
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
302
  return . Ok . maybe JSNull showJSON $ fmap TimeAsDoubleJSON time
303

Klaus Aehlig's avatar
Klaus Aehlig committed
304
305
306
307
308
309
310
311
312
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

313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
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

331
332
333
334
handleCall _ qstat  cfg (CancelJob jid) = do
  let jName = (++) "job " . show $ fromJobId jid
  dequeueResult <- dequeueJob qstat jid
  case dequeueResult of
335
336
337
338
339
340
341
342
343
344
345
346
347
    Ok True ->
      let jobFileFailed = (,) False
                          . (++) ("Dequeued " ++ jName
                                  ++ ", but failed to mark as cancelled: ")
          jobFileSucceeded _ = (True, "Dequeued " ++ jName)
      in liftM (Ok . showJSON . genericResult jobFileFailed jobFileSucceeded)
         . runResultT $ do
            logDebug $ jName ++ " dequeued, marking as canceled"
            qDir <- liftIO queueDir
            (job, _) <- ResultT $ loadJobFromDisk qDir True jid
            now <- liftIO currentTimestamp
            let job' = cancelQueuedJob now job
            writeAndReplicateJob cfg qDir job'
348
349
    Ok False -> do
      logDebug $ jName ++ " not queued; trying to cancel directly"
Petr Pudlak's avatar
Petr Pudlak committed
350
      fmap showJSON <$> cancelJob jid
351
352
    Bad s -> return . Ok . showJSON $ (False, s)

353
354
355
356
357
358
359
360
361
362
363
364
365
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
366
367
                       renameResult <- safeRenameFile queueDirPermissions
                                         live archive
368
369
                       putMVar qlock ()
                       case renameResult of
370
371
372
373
                         Bad s -> return . Bad . JobQueueError
                                    $ "Archiving failed in an unexpected way: "
                                        ++ s
                         Ok () -> do
374
375
                           _ <- executeRpcCall mcs
                                  $ RpcCallJobqueueRename [(live, archive)]
376
                           return . Ok $ showJSON True
377
378
                     else archiveFailed

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

390
391
392
handleCall _ _ _ (PickupJob _) =
  return . Bad
    $ GenericError "Luxi call 'PickupJob' is for internal use only"
393

394
395
{-# ANN handleCall "HLint: ignore Too strict if" #-}

396
397
-- | 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
398
computeJobUpdate :: ConfigData -> JobId -> [String] -> JSValue
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
                    -> 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)

418
419
420
421
422
423
424
425

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

luxiExec
    :: LuxiConfig
    -> LuxiOp
    -> IO (Bool, GenericResult GanetiException JSValue)
luxiExec (qlock, qstat, creader) args = do
426
  cfg <- creader
427
428
429
  result <- handleCallWrapper qlock qstat cfg args
  return (True, result)

430
luxiHandler :: LuxiConfig -> U.Handler LuxiOp IO JSValue
431
432
433
434
435
436
luxiHandler cfg = U.Handler { U.hParse         = decodeLuxiCall
                            , U.hInputLogShort = strOfOp
                            , U.hInputLogLong  = show
                            , U.hExec          = luxiExec cfg
                            }

437
-- | Type alias for prepMain results
438
type PrepResult = (Server, IORef (Result ConfigData), JQStatus)
439

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

Thomas Thrainer's avatar
Thomas Thrainer committed
444
-- | Prepare function for luxid.
445
446
prepMain :: PrepFn () PrepResult
prepMain _ _ = do
447
448
449
  Exec.isForkSupported
    >>= flip exitUnless "The daemon must be compiled without -threaded"

450
  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
  qlockFile <- jobQueueLockFile
466
  _ <- lockFile qlockFile >>= exitIfBad "Failed to obtain the job-queue lock"
Klaus Aehlig's avatar
Klaus Aehlig committed
467
  qlock <- newMVar ()
468

Klaus Aehlig's avatar
Klaus Aehlig committed
469
470
  _ <- P.installHandler P.sigCHLD P.Ignore Nothing

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