Commits

Charles Deakins committed a174366

Added module CommonStuff.hs

Comments (0)

Files changed (5)

+module CommonStuff 
+(
+    media,
+    onFocus,
+    uploadDir,
+    uploadDirCustom,
+    myfromJust,
+    indexHeader,
+    indexHeaderRedirect
+)
+where
+
+import Network.FastCGI
+import Text.XHtml
+import System.Random 
+import Database.HDBC 
+import Database.HDBC.Sqlite3
+import Data.Time
+import System.Cmd
+import Data.List
+import Data.List.Split
+
+{- 
+ - Html attribute media and onFocus are undefined in Text.XHtml so we define them here.
+-}
+media :: String -> HtmlAttr
+media   = strAttr "media"
+
+onFocus :: String -> HtmlAttr
+onFocus = strAttr "onFocus"
+
+{- 
+ - Upload directories, uploadDir is for original size images, uploadDirCustom for images resized to 192x192... 
+-}
+uploadDir :: [Char]
+uploadDir         = "./uploadDir/"
+
+uploadDirCustom :: [Char]
+uploadDirCustom   = "./uploadDirCustom/"
+
+{-
+ - Because fromJust Nothing returns a error.
+-}
+myfromJust :: Maybe [Char] -> [Char]
+myfromJust (Just a) = a
+myfromJust Nothing  = ""
+
+{-
+ - Index header.
+-}
+indexHeader :: Html
+indexHeader = thelink ! [href "default.css", rel "stylesheet", thetype "text/css", media "screen"] << "" 
+                    +++ meta ! [httpequiv "content-type", content "text/html; charset=UTF-8"]
+                    +++ meta ! [name "keywords", content "imgcons, images, pictures, image upload"]
+                    +++ meta ! [name "description", content "A free, simple web image upload service."]
+                    +++ thetitle << "imgcons image share"
+
+{-
+ - Index header used to redirect to another page.
+-}
+indexHeaderRedirect :: [Char] -> Html
+indexHeaderRedirect redirectTo = thelink ! [href "default.css", rel "stylesheet", thetype "text/css", media "screen"] << "" 
+                            +++ meta ! [httpequiv "content-type", content "text/html; charset=UTF-8"]
+                            +++ meta ! [name "keywords", content "imgcons, images, pictures, image upload"]
+                            +++ meta ! [name "description", content "A free, simple web image upload service."]
+                            +++ meta ! [httpequiv "REFRESH", content ("3,url=" ++ redirectTo)] 
+
 import Text.XHtml
 import Database.HDBC 
 import Database.HDBC.Sqlite3
-
-
-{- 
- - html attribute media is undefined in Text.XHtml so we define it here.
--}
-media :: String -> HtmlAttr
-media             = strAttr "media"
-
-{- 
- - Upload directories, uploadDir is for original size images, uploadDirCustom for images resized to 192x192 (thumbnail size) 
--}
-uploadDir :: [Char]
-uploadDir         = "./uploadDir/"
-
-uploadDirCustom :: [Char]
-uploadDirCustom      = "./uploadDirCustom/"
+import CommonStuff
 
 {- 
  - Form for choosing a upload picture.
                 +++ input ! [thetype "submit", value "Upload"])
                 +++ "2MB max, jpg, jpeg, gif, png, tiff, bmp"
 
-
-{- 
- - creates index page header
--}
-indexHeader :: Html
-indexHeader = (thelink ! [href "default.css", rel "stylesheet", thetype "text/css", media "screen"] << "" 
-                    +++ meta ! [httpequiv "content-type", content "text/html; charset=UTF-8"]
-                    +++ meta ! [name "keywords", content "imgcons, images, pictures, image upload"]
-                    +++ meta ! [name "description", content "A free, simple web image upload service."])
-                    +++ thetitle << "imgcons image share"
 {- 
  - creates an index body, input is a 6-tuple containing image names that are displayed
 -}
 import Data.Time
 import System.Cmd
 import Control.Exception
+import CommonStuff
 
 
-{- 
- - Html attribute media is undefined in Text.XHtml so we define it here.
--}
-media :: String -> HtmlAttr
-media             = strAttr "media"
-
-{- 
- - Upload directories, uploadDir is for original size images, uploadDir192 for images resized to 192x192....
--}
-uploadDir :: [Char]
-uploadDir         = "./uploadDir/"
-
-uploadDirCustom :: [Char]
-uploadDirCustom   = "./uploadDirCustom/"
-
-{-
- - Because fromJust Nothing returns a error.
--}
-myfromJust :: Maybe [Char] -> [Char]
-myfromJust (Just a) = a
-myfromJust Nothing  = ""
-
 {-
  - Generates a random name of length 20 containing chars from a-z, checks if
  - the database already contains that name, if calls itself again to do another
  - Various completed pages, self-explanatory.
 -}
 errorPage :: HTML a => a -> Html
-errorPage b = header << indexHeader "index.fcgi" +++ body << b
+errorPage b = header << indexHeaderRedirect "index.fcgi" +++ body << b
 
 successPage :: HTML a => [Char] -> a -> Html
-successPage a b = header << indexHeader ("view.fcgi?file=" ++ (drop 12 a)) +++ body << b
+successPage a b = header << indexHeaderRedirect ("view.fcgi?file=" ++ (drop 12 a)) +++ body << b
 
 page :: HTML a => [Char] -> a -> Html
-page t b = header << indexHeader t +++ body << b
+page t b = header << indexHeaderRedirect t +++ body << b
 
 {-
  - Creates the initial database. Runs only once when uncommented in function
                         a <- liftIO $ quickQuery conn "SELECT number FROM images WHERE name = ?" [toSql name]
                         return (a /= [])
 
-{-
- - Index header used to redirect to another page.
--}
-indexHeader :: [Char] -> Html
-indexHeader redirectTo = header 
-                << (thelink ! [href "default.css", rel "stylesheet", thetype "text/css", media "screen"] << "" 
-                    +++ meta ! [httpequiv "content-type", content "text/html; charset=UTF-8"]
-                    +++ meta ! [name "keywords", content "imgcons, images, pictures, image upload"]
-                    +++ meta ! [name "description", content "A free, simple web image upload service."])
-                    +++ meta ! [httpequiv "REFRESH", content ("3,url=" ++ redirectTo)] 
-
 {- 
  - Main programs, self-explanatory
 -}
 import System.Cmd
 import Data.List
 import Data.List.Split
-{- 
- - Html attribute media and onFocus are undefined in Text.XHtml so we define them here.
--}
-media :: String -> HtmlAttr
-media   = strAttr "media"
+import CommonStuff
 
-onFocus :: String -> HtmlAttr
-onFocus = strAttr "onFocus"
-
-{- 
- - Upload directories, uploadDir is for original size images, uploadDirCustom for images resized to 192x192... 
--}
-uploadDir :: [Char]
-uploadDir         = "./uploadDir/"
-
-uploadDirCustom :: [Char]
-uploadDirCustom   = "./uploadDirCustom/"
-
-{-
- - fromJust Nothing returns an error so we use myfromJust.
--}
-myfromJust :: Maybe [Char] -> [Char]
-myfromJust (Just a) = a
-myfromJust Nothing  = ""
 
 {-
  - Self explanatory.
                 +++ option ! [value "192x192"] << "192x192 pixels"
                 +++ option ! [value "256x256"] << "256x256 pixels"
 
-{-
- - Header for redirection.
--}
-redirectHeader :: [Char] -> Html
-redirectHeader redirectTo =  
-                thelink ! [href "default.css", rel "stylesheet", thetype "text/css", media "screen"] << "" 
-                    +++ meta ! [httpequiv "content-type", content "text/html; charset=UTF-8"]
-                    +++ meta ! [name "keywords", content "imgcons, images, pictures, image upload"]
-                    +++ meta ! [name "description", content "A free, simple web image upload service."]
-                    +++ meta ! [httpequiv "REFRESH", content ("3,url=" ++ redirectTo)] 
-                    +++ thetitle << "imgcons image share"
-
-{-
- - Index header.
--}
-indexHeader :: Html
-indexHeader = thelink ! [href "default.css", rel "stylesheet", thetype "text/css", media "screen"] << "" 
-                    +++ meta ! [httpequiv "content-type", content "text/html; charset=UTF-8"]
-                    +++ meta ! [name "keywords", content "imgcons, images, pictures, image upload"]
-                    +++ meta ! [name "description", content "A free, simple web image upload service."]
-                    +++ thetitle << "imgcons image share"
 
 {-
  - Makes the html for the page body, input is file name and html paragraphs. Resize form is commented since resize.fcgi is not complete.
  - Self explanatory.
 -}
 errorPage   :: HTML a => a -> Html
-errorPage b   = header << redirectHeader "index.fcgi" +++ body << b
+errorPage b   = header << indexHeaderRedirect "index.fcgi" +++ body << b
 
 successPage :: HTML a => a -> Html
 successPage b = header << indexHeader                 +++ body << b
 
 
 # compile everything
+ghc --make CommonStuff.hs
 ghc --make -o index.fcgi codeIndex.hs
 ghc --make -o resize.fcgi codeResize.hs
 ghc --make -o upload.fcgi codeUpload.hs