This is the last entry in a series where we write a file serving web application from start to finish. Today we're going to add two user-facing features. One of these will be an addition to the preview page so that images can be viewed. The other will be to place a download link on the preview page. # Using Unique Identifiers Before adding any features, I want to improve the way files are stored in memory. Right now, each file's name and contents are stored in an association list, `[(Text, ByteString)]`. It's possible for multiple entries to share the same name. This is a problem because `getById` operates on the assumption that files can be uniquely looked up by name. If we were to continue expanding this application there would be other problems with our list of files as well. We might at some point want to add the ability to rename files, for example. File names are part of each URL. Renaming them would break web links. ## Step 1: Access Files by Int What we need is a pool of unique numbers, and the best place to store it is in the foundation type. Let's go a step further and define a data type for uploaded files as well. We'll continue using an association list, but file names and contents will now be keyed on their unique number as a group. ``` haskell -- type StoredFile = (Text, ByteString) -- type Store = [StoredFile] -- data App = App (TVar Store) {-hi-}data StoredFile = StoredFile !Text !ByteString type Store = [(Int, StoredFile)] data App = App (TVar Int) (TVar Store){-/hi-} ``` We'll need a way to generate these unique numbers. The following STM action will be put in "Foundation.hs" along with other accessor functions. ``` haskell getNextId :: App -> STM Int getNextId (App tnextId _) = do nextId <- readTVar tnextId writeTVar tnextId $ nextId + 1 return nextId ``` These are not very invasive changes. We're still using an association list to keep track of files. The only difference is that they are keyed on an `Int` rather than a `Text`. In cases like this I like to update obvious things such as type signatures first, and then work through compiler errors to make all the needed adjustments in function bodies. ``` active haskell web {-# START_FILE Dispatch.hs #-} -- show -- /show {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Dispatch where import Yesod import Foundation import Handler.Home import Handler.Preview mkYesodDispatch "App" resourcesApp {-# START_FILE Foundation.hs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Foundation where import Control.Concurrent.STM import Data.ByteString.Lazy (ByteString) import Data.Default import Data.Text (Text) import qualified Data.Text as Text import Text.Hamlet import Yesod import Yesod.Default.Util -- show -- type StoredFile = (Text, ByteString) -- type Store = [StoredFile] -- data App = App (TVar Store) {-hi-}data StoredFile = StoredFile !Text !ByteString type Store = [(Int, StoredFile)] data App = App (TVar Int) (TVar Store){-/hi-} instance Yesod App where defaultLayout widget = do pc <- widgetToPageContent $ $(widgetFileNoReload def "default-layout") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") instance RenderMessage App FormMessage where renderMessage _ _ = defaultFormMessage mkYesodData "App" $(parseRoutesFile "config/routes") {-hi-}getNextId :: App -> STM Int getNextId (App tnextId _) = do nextId <- readTVar tnextId writeTVar tnextId $ nextId + 1 return nextId{-/hi-} -- getList :: Handler [StoredFile] {-hi-}getList :: Handler [(Int, StoredFile)]{-/hi-} getList = do App _ tstore <- getYesod liftIO $ readTVarIO tstore addFile :: App -> StoredFile -> Handler () addFile app@(App _ tstore) file = liftIO . atomically $ do nextId <- getNextId app modifyTVar tstore $ \ files -> (nextId, file) : files -- getById :: Text -> Handler ByteString {-hi-}getById :: Int -> Handler StoredFile{-/hi-} getById ident = do App _ tstore <- getYesod store <- liftIO $ readTVarIO tstore case lookup ident store of Nothing -> notFound Just file -> return file -- /show {-# START_FILE Main.hs #-} -- show -- /show {-# LANGUAGE OverloadedStrings #-} module Main where import Control.Concurrent.STM import Yesod import Dispatch () import Foundation main :: IO () main = do tnextid <- newTVarIO 1 tstore <- newTVarIO [] warpEnv $ App tnextid tstore {-# START_FILE Handler/Home.hs #-} -- show -- /show {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Handler.Home where import Control.Monad.Trans.Resource import qualified Data.ByteString.Lazy as L import Data.Conduit import Data.Conduit.Binary import Data.Default import Yesod import Yesod.Default.Util import Foundation getHomeR :: Handler Html getHomeR = do (formWidget, formEncType) <- generateFormPost uploadForm storedFiles <- getList defaultLayout $ do setTitle "File Processor" $(widgetFileNoReload def "home") postHomeR :: Handler Html postHomeR = do ((result, _), _) <- runFormPost uploadForm case result of FormSuccess fi -> do app <- getYesod fileBytes <- runResourceT $ fileSource fi $$ sinkLbs addFile app $ StoredFile (fileName fi) fileBytes _ -> return () redirect HomeR uploadForm = renderDivs $ fileAFormReq "file" {-# START_FILE Handler/Preview.hs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module Handler.Preview where import Control.Exception hiding (Handler) import qualified Data.ByteString.Lazy as LB import Data.Default import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import Text.Blaze import Yesod import Yesod.Default.Util import Foundation -- show -- getPreviewR :: Text -> Handler Html {-hi-}getPreviewR :: Int -> Handler Html{-/hi-} getPreviewR fileid = do StoredFile filename bytes <- getById fileid defaultLayout $ do setTitle . toMarkup $ "File Processor - " `Text.append` filename previewBlock <- liftIO $ preview bytes $(widgetFileNoReload def "preview") preview :: LB.ByteString -> IO Widget preview bytes = do eText <- try . evaluate $ LT.decodeUtf8 bytes :: IO (Either SomeException LT.Text) return $ case eText of Left _ -> errorMessage Right text -> [whamlet|
#{text}|] where errorMessage = [whamlet|Unable to display file contents.|] -- /show {-# START_FILE templates/default-layout.cassius #-} -- show -- /show body font-family: Tahoma, Geneva, sans-serif font-size: 1pc form clear: both margin:auto position:relative text-decoration: none -webkit-border-radius: 5pt -moz-border-radius: 5pt border-radius: 5pt padding:1em border: 1pt solid #999 border: inset 1pt solid #333 /* Force form elements to be consistent with each other */ input, textarea, select, button margin: 1pt -webkit-box-sizing: border-box -moz-box-sizing: border-box box-sizing: border-box select width: 100% input display:block border: 1pt solid #999 input[type=submit] float: right background: #09C color: #fff -webkit-border-radius: 5pt -moz-border-radius: 5pt border-radius: 5pt border: 1pt solid #999 /* Change color on mouseover */ input[type=submit]:hover background:#fff color:#09c /* force bottom border to extend below floating elements */ form::after content: "" display: block visibility: hidden clear: both /* add rounded grey box around text */ pre -webkit-border-radius: 5pt -moz-border-radius: 5pt border-radius: 5pt border: 1pt solid #999 background: #DDD margin: 1em padding: 1em white-space: pre-wrap {-# START_FILE templates/default-layout.hamlet #-} -- show -- /show ^{widget} {-# START_FILE templates/default-layout-wrapper.hamlet #-} -- show -- /show $newline never $doctype 5#{pageTitle pc} ^{pageHead pc} ^{pageBody pc} {-# START_FILE templates/home.hamlet #-} -- show -- /showPreviously submitted files $if null storedFiles
No files have been uploaded yet. $else