build DOI resolver service at startup

Application.hs

@@ -77,6 +77,7 @@ import qualified Data.Map.Strict as M
 import Control.Concurrent.STM
 import Control.Concurrent.MVar
 import Presenter.StarExec.Connection (killmenothing, initial_login)
+import Presenter.DOI
 
 -- import Control.Concurrent.SSem
 import qualified Control.Concurrent.FairRWLock as Lock
@@ -143,8 +144,11 @@ makeFoundation conf = do
     -- Connection semaphore
     conS <- Lock.new
 
+    -- resolver
+    doiS <- makeDOI_for_2014_2015
+
     let logger = Yesod.Core.Types.Logger loggerSet' getter
-        foundation = App conf s p manager dbconf logger session crCache dbS conS
+        foundation = App conf s p manager dbconf logger session crCache dbS conS doiS
 
     -- Perform database migration using our application's logging settings.
     runLoggingT

Foundation.hs

@@ -21,6 +21,7 @@ import Presenter.Model
 --import Presenter.Model.RouteTypes
 --import Presenter.Model.Query
 --import Model
+import Presenter.DOI
 import Text.Jasmine (minifym)
 import Text.Hamlet (hamletFile)
 import Yesod.Core.Types (Logger)
@@ -50,6 +51,7 @@ data App = App
     , compResultsCache :: TVar (M.Map CompetitionMeta (TVar (Maybe CompetitionResults)))
     , dbSem :: Lock.RWLock
     , conSem :: Lock.RWLock
+    , doiService :: DOIService
     }
 
 instance HasHttpManager App where

Presenter/DOI.hs

@@ -4,16 +4,21 @@
 
 module Presenter.DOI where
 
-import Import
+import Prelude
 import Presenter.DOI.Type as DOI
 import Presenter.Model.StarExec
-import Presenter.StarExec.Commands (getDefaultSpaceXML)
+import Presenter.StarExec.Space (getDefaultSpaceXML)
+import Presenter.Model.RouteTypes
 
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 import qualified Data.Text as T
 import System.IO
 import Control.Monad ( forM )
+import Control.Applicative
+import Data.Monoid ((<>))
+
+type DOIService =  ( M.Map BenchmarkID DOI, M.Map DOI T.Text)
 
 -- | reads a space build from a file like "TPDB-10.3_XML.zip"
 -- returns a map with entries like
@@ -33,8 +38,8 @@ spaceToNames sp =
 -- handle duplicates in the correct way.
 -- watch out: assigned numbers depend on file contents and order.
 makeDOI :: [ FilePath ]
-        -> IO ( M.Map BenchmarkID DOI, M.Map DOI T.Text)
-makeDOI fs = do
+        -> IO DOIService
+makeDOI fs = do 
   ms <- forM fs $ \ f -> do
     hPutStrLn stderr $ unwords [ "reading space file", f ]
     Just sp <- getDefaultSpaceXML f

Presenter/StarExec/Commands.hs

@@ -33,6 +33,7 @@ import qualified Network.HTTP.Client.MultipartFormData as MP
 import Presenter.StarExec.Urls
 import Presenter.PersistHelper
 import Presenter.StarExec.Connection
+import Presenter.StarExec.Space
 import qualified Codec.Archive.Zip as Zip
 import qualified Data.Csv as CSV
 import qualified Data.Vector as Vector
@@ -76,9 +77,6 @@ safeHead defaultVal [] = defaultVal
 decodeUtf8Body :: Response BSL.ByteString -> Text
 decodeUtf8Body = TE.decodeUtf8 . BSL.toStrict . responseBody
 
-cursorFromDOM :: BSL.ByteString -> Cursor
-cursorFromDOM = fromDocument . Text.HTML.DOM.parseLBS
-
 getFirstTitle :: Cursor -> Text
 getFirstTitle c = head $ content h1
   where h1 = head $ descendant c >>= element "h1" >>= child
@@ -255,10 +253,6 @@ getJobInfo _ _jobId = do
       return $ Just $ constructJobInfo _jobId jobTitle tds
 
 
-getDefaultSpaceXML :: MonadIO m => FilePath -> m (Maybe Space)
-getDefaultSpaceXML fp = do
-    s <- liftIO $ BSL.readFile fp
-    makeSpace s
 
 getSpaceXML :: Int -> Handler (Maybe Space)
 getSpaceXML _spaceId = do
@@ -279,45 +273,6 @@ getSpaceXML _spaceId = do
 
 
 
-
--- | this is applied to the contents of a zipped XML space description file
--- as downloaded from starexec.
-makeSpace :: MonadIO m => BSL.ByteString -> m (Maybe Space)
-makeSpace bs = do
-  let archive = Zip.toArchive bs
-      xml_entries = filter ( \ e -> isSuffixOf ".xml" $ Zip.eRelativePath e ) 
-                 $ Zip.zEntries archive 
-  let spaces =  case xml_entries of
-        [ e ] -> do
-          let cursor = cursorFromDOM $ Zip.fromEntry e
-              root = laxElement "tns:Spaces" cursor >>= child
-              solver r = r >>= laxElement "Solver" >>= \ s -> return $ SolverInSpace
-                  { soId = case attribute "id" s of
-                       [i] -> read $ T.unpack i ; _ -> -1
-                  , soName = case attribute "name" s of
-                                 [ n ] -> n ; _ -> "noname"
-                  }
-              walk :: [ Cursor ] -> [ Space ]
-              walk r = r >>= laxElement "Space" >>= \ s -> return
-                     Space { spId = case attribute "id" s of
-                                 [ i ] -> read $ T.unpack i ; _ -> -1
-                           , spName = case attribute "name" s of
-                                 [ n ] -> n ; _ -> "noname"
-                           , benchmarks_with_names = child s
-                                >>= laxElement "benchmark" >>= \ b ->
-                                  (,) <$> ( read <$> T.unpack <$> attribute "id" b )
-                                      <*> attribute "name" b
-                           , solvers = child s >>= \ c -> solver [c]
-                           , children = child s >>= \ c ->  walk [c]
-                           }
-          walk root
-        _ -> []
-
-  case spaces of
-      [s] -> return $ Just s
-      _ -> do
-          liftIO $ putStrLn "====== no space ======"
-          return Nothing
 
 getBenchmark :: StarExecConnection -> Int -> Handler (BSL.ByteString)
 getBenchmark _ bmId = do

Presenter/StarExec/Space.hs

@@ -0,0 +1,65 @@
+module Presenter.StarExec.Space where
+
+import Presenter.Model.StarExec
+
+import Text.HTML.DOM
+import Text.HTML.TagSoup
+import Text.XML.Cursor
+import Codec.Compression.GZip
+import qualified Codec.Archive.Zip as Zip
+import qualified Data.ByteString.Lazy as BSL
+
+import Prelude
+import System.IO
+import Control.Monad.IO.Class
+import qualified Data.Text as T
+import Data.List ( isSuffixOf )
+
+getDefaultSpaceXML :: MonadIO m => FilePath -> m (Maybe Space)
+getDefaultSpaceXML fp = do
+    s <- liftIO $ BSL.readFile fp
+    makeSpace s
+
+
+-- | this is applied to the contents of a zipped XML space description file
+-- as downloaded from starexec.
+makeSpace :: MonadIO m => BSL.ByteString -> m (Maybe Space)
+makeSpace bs = do
+  let archive = Zip.toArchive bs
+      xml_entries = filter ( \ e -> isSuffixOf ".xml" $ Zip.eRelativePath e ) 
+                 $ Zip.zEntries archive 
+  let spaces =  case xml_entries of
+        [ e ] -> do
+          let cursor = cursorFromDOM $ Zip.fromEntry e
+              root = laxElement "tns:Spaces" cursor >>= child
+              solver r = r >>= laxElement "Solver" >>= \ s -> return $ SolverInSpace
+                  { soId = case attribute "id" s of
+                       [i] -> read $ T.unpack i ; _ -> -1
+                  , soName = case attribute "name" s of
+                                 [ n ] -> n ; _ -> "noname"
+                  }
+              walk :: [ Cursor ] -> [ Space ]
+              walk r = r >>= laxElement "Space" >>= \ s -> return
+                     Space { spId = case attribute "id" s of
+                                 [ i ] -> read $ T.unpack i ; _ -> -1
+                           , spName = case attribute "name" s of
+                                 [ n ] -> n ; _ -> "noname"
+                           , benchmarks_with_names = child s
+                                >>= laxElement "benchmark" >>= \ b ->
+                                  (,) <$> ( read <$> T.unpack <$> attribute "id" b )
+                                      <*> attribute "name" b
+                           , solvers = child s >>= \ c -> solver [c]
+                           , children = child s >>= \ c ->  walk [c]
+                           }
+          walk root
+        _ -> []
+
+  case spaces of
+      [s] -> return $ Just s
+      _ -> do
+          liftIO $ putStrLn "====== no space ======"
+          return Nothing
+
+cursorFromDOM :: BSL.ByteString -> Cursor
+cursorFromDOM = fromDocument . Text.HTML.DOM.parseLBS
+