factorization diagrams with happstack (http://diagrams.alpmestan.com)

root / Main.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Monad.IO.Class (liftIO)
import Data.Text (Text, append, pack)
import Data.Text.Lazy (null)
import Data.Text.Lazy.IO (writeFile)
import Data.Text.Lazy.Read
import Diagrams.Backend.SVG
import Diagrams.Prelude hiding (value, (<.>))
import Factorization
import Happstack.Lite
import System.FilePath
import System.Directory (doesFileExist, removeFile)
import System.Random.MWC
import System.Timeout
import Text.Blaze.Html5 (Html, form, input, p, toHtml, label)
import Text.Blaze.Html5.Attributes (action, enctype, name, type_)
import Text.Blaze.Internal (textValue)
import Text.Blaze.Renderer.Text (renderMarkup)
import Text.Blaze.Svg11
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A

main :: IO ()
main = withSystemRandom $ \gen -> do
  serve Nothing (diagramsApp gen)

diagramsApp gen = msum [ dir "about" about
                   , dir "random" (randomFacto gen)
                   , dir "diagrams" $ serveDirectory EnableBrowsing [] "diagrams"
                   , homePage
                   ]

template :: Text -> Html -> Response
template ti body = toResponse $
  H.html $ do
    H.head $ do
      H.title (toHtml ("Factorization diagrams - " `append` ti))
    H.body $ do
      H.div ! A.style "text-align: center;" $ do
        H.h1 "Factorization diagrams"
        p $ do
          "(based on "
          H.a ! A.href "http://mathlesstraveled.com/2012/10/05/factorization-diagrams/" $ "Brent Yorgey's code"
          " - by "
          H.a ! A.href "http://alpmestan.com" $ "Alp Mestanogullari"
          ")"
        p $ do
          H.a ! A.href "/" $ "Home"
          toHtml (" - " :: Text)
          H.a ! A.href "/random" $ "Random"
          toHtml (" - " :: Text)
          H.a ! A.href "/about" $ "About"
      H.div ! A.style "text-align: center; width: 600px; height: 500px; margin: 0px auto;" $ body

homePage :: ServerPart Response
homePage = msum [ formP, formAndDiagramP ]

  where
    formP = do
      method GET
      ok $ template "Home" $ do
       formN

    formAndDiagramP = do
      method POST
      nText <- lookText "n"
      let en = decimal nText
      case en of
        Left _          -> ok $ template "Home" $ do
          p ! A.style "color: red;" $ "Invalid input"
          formN
        Right (n, rest) -> case Data.Text.Lazy.null rest of
          False -> ok $ template "Home" $ do
            p ! A.style "color: red;" $ "Invalid input"
            formN
          True  -> renderSVGFor n

renderSVGFor :: Integer -> ServerPart Response
renderSVGFor n = do
  let svgFile = diagramsDir </> show n <.> "svg"
  diagramExists <- liftIO . doesFileExist $ svgFile
  mWritten <- case diagramExists of
    False -> let svgContent = renderFactoAsText n in
      liftIO . timeout 10000000 $ Data.Text.Lazy.IO.writeFile svgFile svgContent
    True  -> return $ Just ()
  if mWritten == Nothing then liftIO $ removeFile svgFile else return ()
  ok $ template "Home" $ do       
    case mWritten of
      Nothing -> p ! A.style "color: red;" $ "Timeout"  >> formN
      Just _ -> do
        formN
        p $ do
          "Rendering factorization diagram for "
          H.span ! A.style "color: blue;" $ toHtml (pack (show n))
        H.embed ! A.src (textValue $ pack svgFile) ! A.type_ "image/svg+xml"
              
formN :: Html
formN = do
  form ! action "/" ! enctype "multipart/form-data" ! A.method "POST" $ do
    label ! A.for "n" $ "Number"
    input ! type_ "number" ! A.id "n" ! name "n"
    input ! type_ "submit" ! A.value "Factorize!"
  form ! action "/random" ! enctype "multipart/form-data" ! A.method "POST" $ do
    input ! type_ "submit" ! A.value "Random"

about :: ServerPart Response
about = ok $ template "About" $ do
  p $ do
    "This service has been written on top of the "
    H.a ! A.href "http://www.happstack.com/" $ "Happstack web framework"
    " and the "
    H.a ! A.href "http://projects.haskell.org/diagrams" $ "Diagrams"
    " library."

renderFacto :: Integer -> Svg
renderFacto n = renderDia
                  SVG
                  (SVGOptions (diagramsDir </> show n <.> "svg") (mkSizeSpec (Just 600) (Just 600)))
                  (factorDiagram n)
        
diagramsDir :: FilePath
diagramsDir = "diagrams"

renderFactoAsText = renderMarkup . renderFacto

randomFacto gen = do
  n <- liftIO $ uniformR (0, 5000 :: Int) gen
  renderSVGFor (fromIntegral n)