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)