1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.Solr.Service
    3   ( Solr(..)
    4   , initSolr
    5   , finiSolr
    6   , MonadSolr
    7   ) where
    8 
    9 import Control.Monad (when)
   10 import Control.Monad.IO.Class
   11 import Data.Maybe (isNothing, fromMaybe)
   12 import qualified Network.HTTP.Client as HC
   13 import System.Directory (makeAbsolute)
   14 import System.Environment (getEnvironment)
   15 import System.FilePath ((</>))
   16 import System.IO (openFile, IOMode(AppendMode))
   17 import qualified System.Process as Proc
   18 import System.Timeout (timeout)
   19 
   20 import Databrary.Ops
   21 import Databrary.Has
   22 import qualified Databrary.Store.Config as C
   23 import Databrary.HTTP.Client (HTTPClient)
   24 
   25 data Solr = Solr
   26   { solrRequest :: HC.Request
   27   , solrProcess :: Maybe Proc.ProcessHandle
   28   }
   29 
   30 --confSolr :: FilePath -> FilePath -> IO ()
   31 --confSolr src dst = do
   32 --  mapM_ (\f -> when (head f /= '.') $ copyFile (src </> f) (dst </> f)) =<< getDirectoryContents src
   33 --  withFile (dst </> "enum.xml") WriteMode $ \h -> do
   34 --    hPutStrLn h "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
   35 --    hPutStrLn h "<enumsConfig>"
   36 --    pe h "permission" PermissionNONE
   37 --    pe h "release" ReleasePRIVATE
   38 --    hPutStrLn h "</enumsConfig>"
   39 --  where
   40 --  pe h n t = do
   41 --    hPutStrLn h $ "<enum name=\"" ++ n ++ "\">"
   42 --    forM_ pgEnumValues $ \(x, s) -> hPutStrLn h $ "  <value>" ++ const s (x `asTypeOf` t) ++ "</value>"
   43 --    hPutStrLn h "</enum>"
   44 
   45 initSolr :: Bool -> C.Config -> IO Solr
   46 initSolr fg conf = do
   47   home <- makeAbsolute $ conf C.! "home"
   48 
   49 {-
   50   dir <- makeAbsolute =<< getDataFileName "solr"
   51   createDirectoryIfMissing True (home </> core </> "conf")
   52   copyFile (dir </> "solr.xml") (home </> "solr.xml")
   53   withFile (home </> core </> "core.properties") WriteMode $ \h ->
   54     hPutStrLn h $ "name=" ++ core
   55   confSolr (dir </> "conf") (home </> core </> "conf")
   56 -}
   57 
   58   -- dir <- getCurrentDirectory
   59   env <- getEnvironment
   60   out <- maybe (return Proc.Inherit) (\f -> Proc.UseHandle <$> openFile f AppendMode) $ conf C.! "log"
   61   let run = conf C.! "run"
   62   print $ "RUN" ++ show run
   63   print $ "HOME" ++ show home
   64   p <- (fromMaybe fg run) `thenReturn`
   65        Proc.createProcess (Proc.proc (fromMaybe "solr" $ conf C.! "bin")
   66                             ["start", "-Djetty.host=" ++ host, "-p", show port, "-f", "-s", home])
   67     { Proc.std_out = out
   68     , Proc.std_err = out
   69     , Proc.close_fds = True
   70     , Proc.env = Just $ env ++ [("SOLR_PID_DIR", home), ("LOG4J_PROPS", home </> "log4j.properties")]
   71     , Proc.create_group = True
   72     }
   73 
   74   req <- HC.parseRequest $ "http://" ++ host ++ "/solr/" ++ core ++ "/"
   75   return Solr
   76     { solrRequest = req
   77       { HC.port = port
   78       , HC.redirectCount = 0
   79       , HC.cookieJar = Nothing
   80       }
   81     , solrProcess = (\(_,_,_,h) -> h) <$> p
   82     }
   83   where
   84   host = fromMaybe "127.0.0.1" $ conf C.! "host"
   85   port = conf C.! "port"
   86   core = fromMaybe "databrary" $ conf C.! "core"
   87 
   88 finiSolr :: Solr -> IO ()
   89 finiSolr Solr{ solrProcess = Just ph } = do
   90   Proc.interruptProcessGroupOf ph
   91   -- this timeout doesn't actually seem to work:
   92   r <- timeout 10000000 $ Proc.waitForProcess ph
   93   when (isNothing r) $ do
   94     putStrLn "solr failed to stop; terminating..."
   95     Proc.terminateProcess ph
   96 finiSolr _ = return ()
   97 
   98 type MonadSolr c m = (MonadIO m, MonadHas HTTPClient c m, MonadHas Solr c m)