{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
{-| Server module, allows mediawiki2latex to run as webserver -}
module Server where
import Data.Text (Text)
import Happstack.Server hiding (body)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import System.Directory
import System.IO
import Control.Monad.Trans
import Data.ByteString.UTF8
import Data.ByteString.Lazy
hiding (pack, reverse, takeWhile, dropWhile)
import Control.Concurrent
import Control.Monad.State
import ImperativeState hiding (name)
import Hex
import Data.Map.Strict
import Data.Maybe
import System.Process hiding (cwd)
import Data.List
import Text.Blaze.Internal
import Data.Time.Clock.POSIX
import Data.Text (pack)
import Control.DeepSeq
import System.Exit
mytext :: String -> H.Html
mytext = text . pack
pageFrame :: H.Html -> H.Html
pageFrame input
= H.table H.!
A.style
"min-width:100%;border:0px;padding:0;border-spacing:0px 0px;"
$
do H.tr H.! A.style "min-width:100%;border:0px;padding:0" $
do H.td H.! A.style "background-color:#444444" H.! A.colspan "3" $
do H.div H.!
A.style
"color:white;font-size:60;border:20px;font-family:Arial,Helvetica,sans-serif;"
$ H.b $ do mytext "MediaWiki2LaTeX"
H.tr H.! A.style "min-width:100%;border:0px;padding:0" $
do H.td H.! A.style "background-color:#222222" H.! A.colspan "3" $
H.div H.! A.style "padding: 5px;padding-left: 10px" $
H.div H.!
A.style
"padding:3px;display:inline;background-color:#595959;border-radius:3px"
$
H.div H.!
A.style
"font-family: times, serif;display:inline;font-size:20;color:#cccccc"
$ "Home"
H.tr $
do H.td $
H.table H.! A.style "padding:20px" $
do H.tr $
infoBox "MediaWiki to LaTeX"
"MediaWiki to LaTeX converts Wiki pages to LaTeX and PDF. It works with any website running MediaWiki, especially Wikipedia and Wikibooks. MediaWiki to LaTeX is purely written in the purely functional language Haskell. It was mainly devolved by Dirk H\252nniger. The source code is freely available under the terms of the GNU General Public License. Binary releases for the most common operating systems are available for download. The Debian package is maintained by Georges Khaznadar."
H.tr $
infoBox "Contact" $
do mytext "Dirk H\252nniger"
H.br
mytext "Emil Schweitzer Str. S 10"
H.br
mytext "D-47506 Neukirchen Vluyn"
H.br
mytext "Germany"
H.br
mytext "Telephone ++49-2845-3799993"
H.br
H.a H.!
A.href
"mailto:dirk.hunniger@googlemail.com?Subject=MediaWiki2LaTeX"
$ "dirk.hunniger@googlemail.com"
input
H.td $
H.table H.! A.style "padding:20px" $
do H.tr $
infoBox "Documentation and Links" $
do H.ul $
do H.li $
H.a H.!
A.href
"http://de.wikibooks.org/wiki/Benutzer:Dirk_Huenniger/wb2pdf/manual"
$ "Users Manual"
H.li $
H.a H.!
A.href
"http://de.wikibooks.org/wiki/Benutzer:Dirk_Huenniger/wb2pdf"
$ "Project Wiki Page"
H.li $
H.div H.! A.style "font-size:x-large" $
do H.b $
H.a H.!
A.href
"https://de.wikibooks.org/wiki/Benutzer:Dirk_Huenniger/wb2pdf"
$ "Download Full Version for Free"
H.li $
H.a H.!
A.href "http://sourceforge.net/p/wb2pdf/git/ci/master/tree/"
$ "Git Sourcecode Repository"
H.li $
H.a H.!
A.href
"http://de.wikibooks.org/wiki/Benutzer_Diskussion:Dirk_Huenniger/wb2pdf/Requests"
$ "Bug Tracker"
H.tr $
infoBox "Web Interface" $
do mytext
"The web interface was artistically designed by Thomas Blume using "
H.a H.! A.href "http://www.yaml.org/" $ "YAML"
mytext
". It was technically implemented by Dirk H\252nniger using the Blaze Html Framework in Haskell. Important ideas on the design of the user interface were contributed by Georges Khaznadar and Martin Wermers. The server this interface is running on is run by a WMF, who have to cover the costs, so "
H.b "please consider downloading the full version for free"
mytext
" and running at on your own hardware instead of using this server."
infoBox :: String -> H.Html -> H.Html
infoBox heading content
= H.td $
H.div H.! A.style "padding:10px" $
H.div H.!
A.style
"text-align:jusitfy;text-justify:inter-word;padding:20px;border-color:#aaaaaa;background-color:#f4f4f4;border-radius:5px;border-width:1px;border-style:solid;font-family:Arial,Helvetica,sans-serif"
$
do H.div H.! A.style "font-size:30" $ H.b (mytext heading)
H.br
H.div H.! A.style "text-align:jusitfy" $ content
data ProgressInfo = ProgressInfo{progress :: Double,
filename :: Maybe String, startTime :: Double, barValue :: Double,
lastStepTime :: Double, lastRuntime :: Double, extension :: String,
failed :: Bool}
instance NFData ProgressInfo where
rnf a = a `seq` ()
{-| IO action to run the server -}
serve :: Int -> IO ()
serve p
= do a <- newMVar Data.Map.Strict.empty
simpleHTTP nullConf{port = p, timeout = 100000} $
msum
[dirs "progress" $ path $ \ subject -> progressBar a subject,
dirs "file" $ path $ \ subject -> fileFrame a subject,
dirs "fill" $ path $ \ subject -> formPage a subject,
formPage a ""]
{-| template for the start page of the server -}
template :: Text -> H.Html -> Response
template title body
= toResponse $
H.docTypeHtml $
do H.head $
do H.meta H.! A.charset "utf-8"
H.title (H.toHtml title)
H.body $ do body
{-| takes an url to a wiki article and a filename for the temporary file to be created and return a shell command to run mediawiki2latex to compile a pdf document from the given url and write it to the given temporary filename -}
mainAction :: FullConfig -> IO String
mainAction oldcfg
= do cwd <- getCurrentDirectory
let cfg = oldcfg{mainPath = cwd}
return (hex (show cfg))
{-| main webpage of the server containing a from with an entry for an url to a wiki article with returns the pdf on submission of the form -}
gogo :: Eq b => [(a, b)] -> b -> b
gogo ((_, v) : xs) vv
= if vv == v then
case xs of
(h : _) -> (snd h)
_ -> v
else gogo xs vv
gogo [] vv = vv
progressBar ::
MVar (Map Int ProgressInfo) -> String -> ServerPart Response
progressBar t sub
= do let theIndex
= case
(reads (Data.List.takeWhile (/= '.') sub)) :: [(Int, String)] of
((k, _) : _) -> k
_ -> 1
m <- liftIO (takeMVar t)
let uu
= (fromMaybe progressInfoZero (Data.Map.Strict.lookup theIndex m))
let nextKnownRelativeProgressToBeReached
= gogo mylist (progress uu)
let lastReachedKnownRelativeProgress = progress uu
let timeOfLastReachedKnownRelativeProgress = lastStepTime uu
ttime <- liftIO getPOSIXTime
let time = (realToFrac ttime)
let expectedRuntime
= if lastReachedKnownRelativeProgress < 1.0e-2 then 60.0 else
(time - (startTime uu)) / lastReachedKnownRelativeProgress
let runtime = time - startTime uu
let p = lastReachedKnownRelativeProgress +
(1 -
exp
(-(time - timeOfLastReachedKnownRelativeProgress) /
(expectedRuntime *
(nextKnownRelativeProgressToBeReached -
lastReachedKnownRelativeProgress))))
*
(nextKnownRelativeProgressToBeReached -
lastReachedKnownRelativeProgress)
let oldProgressBarValue = barValue uu
let progressBarValue
= oldProgressBarValue +
(max
((p - oldProgressBarValue) * (runtime - (lastRuntime uu)) / 5.0)
0.0)
let prog
= if lastReachedKnownRelativeProgress == 1.0 then 1000 else
if failed uu then 0 else
round (progressBarValue * 1000.0) :: Integer
liftIO $
if not (member theIndex m) then putMVar t m else
putMVar t $!!
(Data.Map.Strict.insert theIndex
uu{barValue = progressBarValue, lastRuntime = runtime}
m)
case filename uu of
Nothing -> do method GET
ok $
template "Converting" $
pageFrame $
infoBox
(if not (member theIndex m) then
"Not enough resources availiable to process your request! Your request has been dropped! Please download the full version for free and run it on your own computer!"
else
(if not (failed uu) then "Conversion Running" else
"Conversion Failed due to timeout or non zero exit code"))
$
do H.meta H.! A.httpEquiv "refresh" H.! A.content "1"
H.table $
do H.tr $
do H.td $
do H.progress H.! A.style wwidth H.!
A.value (stringValue (show (prog)))
H.! A.max "1000"
$ ""
Just _ -> do method GET
ok $
template "Conversion Finished" $
pageFrame $
infoBox "Conversion Finished" $
do H.meta H.! A.httpEquiv "refresh" H.!
A.content
(stringValue
("0;url=/file/" ++
(show theIndex) ++ "." ++ (extension uu)))
H.table $
do H.tr $
do H.td $
do H.progress H.! A.style wwidth H.!
A.value (stringValue (show (1000 :: Integer)))
H.! A.max "1000"
$ ""
fileFrame ::
MVar (Map Int ProgressInfo) -> String -> ServerPart Response
fileFrame t sub
= do let theIndex
= case
(reads (Data.List.takeWhile (/= '.') sub)) :: [(Int, String)] of
((k, _) : _) -> k
_ -> 1
m <- liftIO (takeMVar t)
liftIO $ putMVar t m
let uu
= (fromMaybe progressInfoZero (Data.Map.Strict.lookup theIndex m))
case filename uu of
Just x -> do f <- serveFile (guessContentTypeM mimeTypes) x
_ <- liftIO
(forkIO
(do threadDelay 2000000
removeFile x))
return f
Nothing -> do method GET
ok $
template "Conversion Failed" $
pageFrame $
infoBox "Conversion Failed" $
(mytext "We are sorry the converion failed, please contact our us")
currentlyrunning :: Map Int ProgressInfo -> Bool
currentlyrunning m
= not
(Data.List.all (\ x -> (isJust (filename x)) || (failed x))
(Data.Map.Strict.elems m))
wwidth2 :: [Char]
wwidth2 = "width:400px"
wwidth :: AttributeValue
wwidth = stringValue wwidth2
formPage ::
MVar (Map Int ProgressInfo) -> String -> ServerPart Response
formPage m s
= do decodeBody (defaultBodyPolicy "/tmp/" 0 1000000 1000000)
msum [viewForm, processForm]
where viewForm :: ServerPart Response
viewForm
= do method GET
ok $
template "MediaWiki2LaTeX" $
pageFrame $
infoBox "Create Your PDF" $
do mytext
"To compile MediaWiki pages via LaTeX to PDF choose any URL from "
H.a H.! A.href "http://en.wikipedia.org/" $ "Wikibooks"
mytext
" or any other website running MediaWiki. If you intent to compile a wikibook make sure you use the link to the printable version of the book."
H.br
H.div H.! A.style "font-size:20" $ H.b $ mytext "Send your request"
H.form H.! A.action "/form" H.! A.enctype "multipart/form-data" H.!
A.method "POST"
$
H.div $
do H.table $
do H.tr $
do H.td "URL to the Wiki to be converted"
H.td $
do H.input H.! A.style wwidth H.! A.type_ "text" H.!
A.id "msg"
H.! A.name "msg"
H.! A.value (stringValue s)
H.tr $
do H.td "Output Format"
H.td $
do H.select H.! A.style wwidth H.! A.name "output" $
do H.option H.! A.value "pdf" $ "Compiled PDF"
H.option H.! A.value "zip" $ "Source ZIP"
H.option H.! A.value "epub" $ "EPUB File"
H.option H.! A.value "odt" $
"ODT File (Word Processor)"
H.tr $
do H.td "Template expansion"
H.td $
do H.select H.! A.style wwidth H.! A.name "expansion" $
do H.option H.! A.value "Print" $ "Print"
H.option H.! A.value "BookMode" $ "BookMode"
H.option H.! A.value "MediaWiki" $ "Mediawiki"
H.option H.! A.value "Normal" $ "Normal"
H.tr $
do H.td "Paper"
H.td $
do H.select H.! A.style wwidth H.! A.name "paper" $
do H.option H.! A.value "A4" $ "A4"
H.option H.! A.value "A5" $ "A5"
H.option H.! A.value "B5" $ "B5"
H.option H.! A.value "letter" $ "letter"
H.option H.! A.value "legal" $ "legal"
H.option H.! A.value "executive" $ "executive"
H.tr $
do H.td "Vector graphics"
H.td $
do H.select H.! A.style wwidth H.! A.name "vector" $
do H.option H.! A.value "Rasterize" $ "Rasterize"
H.option H.! A.value "Keep Vector Form" $
"Keep Vector Form"
H.tr $
do H.td ""
H.td $
do H.input H.!
A.style (stringValue (wwidth2 ++ ";height:60px"))
H.! A.type_ "submit"
H.! A.value "Start!"
H.div H.! A.style "text-decoration:underline" $
mytext "Please note:"
H.br
do mytext "The LaTeX source code will be compiled several times to make sure all references are resolved. The whole process will usually take about one minute."
H.br
H.br
H.div H.! A.style "font-size:large" $ H.b "There is a time limit of one hour (≈ 200 pages in PDF) on this server!"
H.br
mytext "Requests taking longer will be terminated and a \"Conversion Failed due to timeout or non zero exit code\" message will be displayed. There is no limit in the downloadable versions shown on the right."
getRunmode "Print" = ImperativeState.HTML
getRunmode "MediaWiki" = ImperativeState.ExpandedTemplates
getRunmode "Normal" = ImperativeState.StandardTemplates
getRunmode "BookMode" = ImperativeState.Book
getRunmode _ = ImperativeState.HTML
processForm :: ServerPart Response
processForm
= do msg <- lookBS "msg"
paperOpt <- lookBS "paper"
vectorOpt <- lookBS "vector"
expansion <- lookBS "expansion"
output <- lookBS "output"
zzz <- liftIO $
do tmpDir <- getTemporaryDirectory
(name, handle) <- openTempFile tmpDir
("MediaWiki2LaTeX" ++
if (toString (toStrict output)) == "zip" then
"zip" else
if (toString (toStrict output)) == "epub" then
"epub" else
if (toString (toStrict output)) == "odt" then
"odt" else "pdf")
hClose handle >> removeFile name
act <- mainAction
FullConfig{selfTest = Nothing, headers = Nothing,
resolution = 300, outputFilename = name,
inputUrl = (toString (toStrict msg)),
runMode =
if
(isInfixOf ("Book:" :: [Char])
(toString (toStrict msg)))
then getRunmode ("BookMode" :: [Char]) else
getRunmode (toString (toStrict expansion)),
paper = (toString (toStrict paperOpt)),
vector =
(toString (toStrict vectorOpt)) ==
"Keep Vector Form",
ImperativeState.copy = Nothing, mainPath = "",
server = Nothing,
outputType =
if (toString (toStrict output)) == "zip" then
ImperativeState.ZipArchive else
if (toString (toStrict output)) == "epub" then
ImperativeState.EPubFile else
if (toString (toStrict output)) == "odt" then
ImperativeState.OdtFile else
ImperativeState.PlainPDF,
compile = Nothing, imgctrb = Nothing}
yy <- newEmptyMVar
mm <- takeMVar m
_ <- if (not (currentlyrunning mm)) then
do _ <- forkIO $
do (i, o, e, h) <- runInteractiveCommand
("mediawiki2latex -x " ++ act)
tt <- getPOSIXTime
let ss
= (if (toString (toStrict output)) == "zip"
then "zip" else
if (toString (toStrict output)) == "epub"
then "epub" else
if (toString (toStrict output)) == "odt"
then "odt" else "pdf")
zz <- forkProgressDriver o m name ss
putMVar yy zz
ex h i e ((realToFrac tt) + 3600.0) m zz ss
return ()
else
do putMVar yy (-1)
return ()
putMVar m mm
zzzz <- takeMVar yy
return zzzz
method POST
ok $
toResponse $
template "Redirect" $
do H.meta H.! A.httpEquiv "refresh" H.!
A.content
(stringValue
("0;url=/progress/" ++
(show zzz) ++
"." ++
(if (toString (toStrict output)) == "zip" then "html" else
"html")))
ex ::
ProcessHandle ->
Handle ->
Handle ->
Double -> MVar (Map Int ProgressInfo) -> Int -> String -> IO ()
ex h i e t m n s
= do tt <- getPOSIXTime
threadDelay 100
if (realToFrac tt) > t then
do System.IO.hPutStr i "\n"
mm <- takeMVar m
putMVar m
(Data.Map.Strict.update (\ x -> Just x{failed = True}) n mm)
else return ()
xi <- hIsOpen i
if xi then hFlush i else return ()
xo <- hIsOpen e
_ <- if xo then System.IO.hGetContents e else return ""
y <- getProcessExitCode h
case y of
Just ee -> if ExitSuccess == ee then
do threadDelay 3000000
mm <- takeMVar m
putMVar m
(Data.Map.Strict.insertWith
(\ new old ->
old{progress = progress new, lastStepTime = realToFrac tt})
n
progressInfoZero{progress = 1.0}
mm)
mmm <- takeMVar m
putMVar m mmm
case Data.Map.Strict.lookup n mmm of
Just yy -> do _ <- takeMVar m
putMVar m
(Data.Map.Strict.insert n yy{filename = Just s} mmm)
_ -> return ()
else
do mm <- takeMVar m
putMVar m
(Data.Map.Strict.update (\ x -> Just x{failed = True}) n mm)
_ -> if (realToFrac tt) > t then return () else ex h i e t m n s
mylist :: [([Char], Double)]
mylist
= [("downloading article and contributor information",
2.540431143798292e-2),
("parsing article text", 5.7625916241286344e-2),
("forking threads to download of images and contributor information on them",
5.8045207449988465e-2),
("precompiling table columns", 8.075814224942594e-2),
("joining threads to download the images and contributor information on them",
0.37003149457779727),
("preparing for PDF generation", 0.5479855803098518),
("preparing images for LaTeX document", 0.637605216120732),
("generating PDF file. LaTeX run 1 of 4", 0.6911489294291799),
("generating PDF file. LaTeX run 2 of 4", 0.7673758195622185),
("generating PDF file. LaTeX run 3 of 4", 0.8463397892914045),
("generating PDF file. LaTeX run 4 of 4", 0.9231746180088297),
("finished", 1.0)]
wwait :: Handle -> IO ()
wwait h
= do b <- hIsEOF h
if b then
do threadDelay 1000
wwait h
else return ()
progressDriver ::
Int -> Handle -> MVar (Map Int ProgressInfo) -> String -> IO ()
progressDriver n o t s
= do xo <- hIsOpen o
threadDelay 100
tt <- getPOSIXTime
l <- if xo then
do wwait o
hGetLine o
else return ""
case
msum
(Data.List.map
(\ (k, v) -> if isInfixOf k l then Just v else Nothing)
mylist)
of
Just x -> do m <- takeMVar t
putMVar t
(Data.Map.Strict.insertWith
(\ new old ->
old{progress = progress new, lastStepTime = realToFrac tt})
n
progressInfoZero{progress = x}
m)
_ -> return ()
m <- readMVar t
case Data.Map.Strict.lookup n m of
Just yy | (progress yy) == 1.0 ->
do _ <- takeMVar t
putMVar t (Data.Map.Strict.insert n yy{filename = Just s} m)
Just yy | (failed yy) -> return ()
_ -> progressDriver n o t s
progressInfoZero :: ProgressInfo
progressInfoZero
= ProgressInfo{progress = 0.0, filename = Nothing, startTime = 0.0,
failed = False, barValue = 0.0, lastStepTime = 0.0,
lastRuntime = 0.0, extension = ""}
forkProgressDriver ::
Handle -> MVar (Map Int ProgressInfo) -> String -> String -> IO Int
forkProgressDriver o t s ext
= do m <- takeMVar t
tt <- getPOSIXTime
let mm
= case (keys m) of
(x : xs) -> Data.List.maximum (x : xs)
_ -> 0
putMVar t
(Data.Map.Strict.insert (mm + 1)
ProgressInfo{progress = 0.0, filename = Nothing,
startTime = realToFrac tt, barValue = 0.0, lastStepTime = 0.0,
lastRuntime = 0.0, extension = ext, failed = False}
m)
_ <- forkIO (progressDriver (mm + 1) o t s)
return (mm + 1)